/usr/lib/dcmtk/cgi-bin/procdel.pl is in dcmtk-www 3.6.0-15.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | #!/usr/bin/perl
#
# Copyright (C) 1996-2010, OFFIS e.V.
# All rights reserved. See COPYRIGHT file for details.
#
# This software and supporting documentation were developed by
#
# OFFIS e.V.
# R&D Division Health
# Escherweg 2
# D-26121 Oldenburg, Germany
#
# for CEN/TC251/WG4 as a contribution to the Computer Assisted Radiology
# (CAR) 1996 DICOM Demonstration.
#
#
# Module: dcmwlm (WWW Component)
#
# Author: Marco Eichelberg
#
# Purpose:
# This perl script allows to delete a procedure entry from a storage area.
#
# Last Update: $Author: joergr $
# Update Date: $Date: 2010-10-14 13:02:01 $
# CVS/RCS Revision: $Revision: 1.2 $
# Status: $State: Exp $
#
# CVS/RCS Log
# $Log: procdel.pl,v $
# Revision 1.2 2010-10-14 13:02:01 joergr
# Updated copyright header. Added reference to COPYRIGHT file.
#
# Revision 1.1 2002/12/03 12:16:11 wilkens
# Added files und functionality from the dcmtk/wlisctn folder to dcmtk/dcmwlm
# so that dcmwlm can now completely replace wlistctn in the public domain part
# of dcmtk. Pertaining to this replacement requirement, another optional return
# key attribute was integrated into the wlm utilities.
#
#
#
require 'prefs.ph';
require 'layout.ph';
require 'password.ph';
require 'lock.ph';
require 'urldecod.ph';
require 'write.ph';
require 'checkvr.ph';
$path_info=$ENV{'PATH_INFO'};
&get_request;
$aetitle = '';
$passwd = '';
$procid = '';
$command = '';
if ($path_info ne '')
{
($dummy, $aetitle, $passwd, $procid, $command, $rest) = split(/\//, $path_info);
}
if (($passwd eq '') || (! &checkurlcode($passwd, $aetitle)))
{
# Password is incorrect.
&page_title("Password invalid");
printf("<A HREF=\"%s\">Click here</A> to return to main menu.\n", $prefs{'main.pl'});
&page_footer;
} else {
# Password is correct.
&set_readlock("$prefs{'data_path'}/$aetitle");
$filename = "$prefs{'data_path'}/$aetitle/$prefs{'datafile'}";
&read_environment($filename);
if ($command eq '')
{
# display warning
&page_title("Delete Procedure");
$decodedid = pack("H*",$procid);
printf("You have requested the deletion of procedure ID <b>'%s'</b>.<br>\n",$decodedid);
printf("<b>Attention:</b> Worklist entries referring to this procedure will <b>not</b> be removed!<p>\n");
# check if there are procedure steps for this procedure
$count=0;
foreach(@PROCEDURESTEP_KEYS)
{
if ($PROCEDURESTEP_VALUES{"$_\\procedure"} eq $decodedid) { $count++; }
}
if ($count>0)
{
printf("<h4>Warning</h4>\n");
printf("%d Procedure Step(s) assigned to this procedure will also be deleted:\n<UL>",$count);
foreach(@PROCEDURESTEP_KEYS)
{
if ($PROCEDURESTEP_VALUES{"$_\\procedure"} eq $decodedid)
{
printf("<li>%s: %s\n", $_, $PROCEDURESTEP_VALUES{"$_\\title"});
}
}
printf("</ul><p>\n");
}
printf("<A HREF=\"%s%s/DELETE\">Delete</A> ", $prefs{'procdel.pl'}, $path_info);
printf("or <A HREF=\"%s%s\">Cancel</A> and return to procedure overview.\n",
$prefs{'procedur.pl'}, $path_info);
&page_footer;
} else {
# erase and back to procedure overview
&set_writelock("$prefs{'data_path'}/$aetitle");
$decodedid = pack("H*",$procid);
# remove procedure key
undef @temp;
foreach(@PROCEDURE_KEYS) { if ($decodedid ne $_) { push(@temp, $_); } }
@PROCEDURE_KEYS = @temp;
# remove values
delete $PROCEDURE_VALUES{"$decodedid\\title"};
delete $PROCEDURE_VALUES{"$decodedid\\description"};
delete $PROCEDURE_VALUES{"$decodedid\\priority"};
# now delete procedure steps assigned to this procedure...
@pstemp = @PROCEDURESTEP_KEYS;
foreach(@pstemp)
{
if ($PROCEDURESTEP_VALUES{"$_\\procedure"} eq $decodedid)
{
$key = $_;
undef @temp;
foreach(@PROCEDURESTEP_KEYS) { if ($key ne $_) { push(@temp, $_); } }
@PROCEDURESTEP_KEYS = @temp;
# remove values
delete $PROCEDURESTEP_VALUES{"$key\\procedure"};
delete $PROCEDURESTEP_VALUES{"$key\\title"};
delete $PROCEDURESTEP_VALUES{"$key\\modality"};
delete $PROCEDURESTEP_VALUES{"$key\\medication"};
delete $PROCEDURESTEP_VALUES{"$key\\contrast"};
delete $PROCEDURESTEP_VALUES{"$key\\location"};
delete $PROCEDURESTEP_VALUES{"$key\\comments"};
}
}
&write_environment($filename);
printf("Location: %s/%s/%s\n\n", $prefs{'procedur.pl'}, $aetitle, $passwd);
}
&release_lock;
}
|