RACMHIS ;HISC/GJC-Radiology Contrast Media History option (driver)
;;5.0;Radiology/Nuclear Medicine;**45**;Mar 16, 1998
;Note: new routine with the release of RA*5*45
;
EN ;begin; find all procedures with a CM audit history
S RADIC="^RAMIS(71,",RADIC(0)="EMQZ",RADIC("A")="Select Procedure: "
S RADIC("S")="I $O(^RAMIS(71,+Y,""AUD"",0))",RAUTIL="RA PROC W/CM"
K ^TMP($J,"RA PROC W/CM") D EN1^RASELCT(.RADIC,RAUTIL,"",1)
I $O(^TMP($J,"RA PROC W/CM",""))="" D D KILL Q
.W !?3,"No procedures have been selected, exiting this option." Q
;
STRTDT ;Prompt for Starting Date
W ! K DIR S DIR(0)="DA^:"_DT_":PEA"
S DIR("A")="Enter the start date for the search: "
S DIR("?",1)="This is the date from which our search will begin."
S DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'FROM'."
S DIR("?",3)="The starting date must not exceed: "_$$FMTE^XLFDT(DT,"1P")_"."
S DIR("?")="Dates associated with a time will not be accepted."
D ^DIR K DIR
I $D(DIRUT) D KILL Q
;int. date/time ^ ext. date/time ^ int. date/time minus one second
S RASTRT=Y_"^"_Y(0)_"^"_$$FMADD^XLFDT(Y,"","","",-1)
;
ENDDT ;Prompt for Ending Date
W ! K DIR S DIR(0)="DA^"_$P(RASTRT,U)_":"_DT_":PEA"
S DIR("A")="Enter the ending date for the search: "
S DIR("?",1)="This is the date in which our search will end."
S DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'TO'."
S DIR("?",3)="The ending date must not exceed: "_$$FMTE^XLFDT(DT,"1P")_"."
S DIR("?",4)="The ending date must not precede: "_$P(RASTRT,U,2)_"."
S DIR("?")="Dates associated with a time will not be accepted."
D ^DIR K DIR
I $D(DIRUT) D KILL Q
;int. date/time ^ ext. date/time ^ int. date/time plus 23hrs, 59 min,
;& 59 seconds
S RASTOP=Y_"^"_Y(0)_"^"_(Y+.235959)
;
F I="RASTRT","RASTOP","^TMP($J," S ZTSAVE(I)=""
K I D EN^XUTMDEVQ("START^RACMHIS","Rad/Nuc Med: Contrast Media History report",.ZTSAVE,,1)
I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,!
;
KILL ;clean up symbol table
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RADIC,RAQUIT,RASTOP,RASTRT,RAUTIL,X
K Y,ZTSAVE,ZTSK,^TMP($J,"RA PROC W/CM")
Q
;
START ;main body
S:$D(ZTQUEUED) ZTREQ="@"
S RAHD="Contrast Media Edit History By Procedure"
S $P(RALINE,"-",(IOM+1))="",RAPG=0,RADT=$$FMTE^XLFDT(DT,"1P")
W:$E(IOST,1,2)="C-" @IOF ;clear screen
D HDR S RAXIT=0,RAPNME=""
F S RAPNME=$O(^TMP($J,"RA PROC W/CM",RAPNME)) Q:RAPNME="" D Q:RAXIT
.S RAXIT=$$S^%ZTLOAD() S:RAXIT ZTSTOP=1 Q:RAXIT
.S RAY=0
.F S RAY=$O(^TMP($J,"RA PROC W/CM",RAPNME,RAY)) Q:'RAY D Q:RAXIT
..S RAXIT=$$S^%ZTLOAD() S:RAXIT ZTSTOP=1 Q:RAXIT
..S RAS=$P(RASTRT,U,3)
..F S RAS=$O(^RAMIS(71,RAY,"AUD","B",RAS)) Q:'RAS!(RAS>$P(RASTOP,U,3)) D Q:RAXIT
...S RAIEN=0
...F S RAIEN=$O(^RAMIS(71,RAY,"AUD","B",RAS,RAIEN)) Q:'RAIEN D Q:RAXIT
....;get changed date/time, CM value, & user
....S RAY(0)=$G(^RAMIS(71,RAY,"AUD",RAIEN,0))
....S RAADT=$$FMTE^XLFDT($P(RAY(0),U),"1P"),RACMU=$P(RAY(0),U,2)
....S RAX=$S($L(RACMU):$$CONTRAST(RACMU),1:"**User deleted all contrast media data**")
....S:+$P(RAY(0),U,3) RAAU=$$GET1^DIQ(200,$P(RAY(0),U,3)_",",.01)
....I $Y>(IOSL-4) D EOS Q:RAXIT
....W !,$E(RAPNME,1,32),?33,RAADT,?55,$E($G(RAAU),1,24)
....I $Y>(IOSL-4) D EOS Q:RAXIT
....;display the past CM data value or that CM data has been deleted
....S X=RAX,DIWL=3,DIWR=70,DIWF="W" D ^DIWP,^DIWW K ^UTILITY($J,"W")
....Q
...Q
..Q
.Q
EXIT ;clean up symbol table, message to user
;if there are no records to print, alert user
W:'$D(RAY(0))#2 !,$$CJ^XLFSTR("*** No Records To Print ***",IOM)
K DIW,DIWF,DIWL,DIWR,DIWT,DN,I,RAADT,RAAU,RACMU,RADT,RAHD,RAI,RAIEN
K RALINE,RAPG,RAPNME,RAS,RAXIT,RAX,RAY,X,Y,Z
Q
;
EOS ; end of screen dialog
I $E(IOST,1,2)="C-" D Q:RAXIT
.K DIR,DIRUT,DTOUT,DUOUT
.S DIR(0)="E" D ^DIR S:$D(DIRUT) RAXIT=1
.K DIR,DIRUT,DTOUT,DUOUT
.Q
;
;'falls' into HDR...
;
HDR ; print header
W:RAPG @IOF S RAPG=RAPG+1
W !,$$CJ^XLFSTR(RAHD,IOM),!,"Run Date: ",RADT,?25,"From: ",$P(RASTRT,U,2),?45,"To: ",$P(RASTOP,U,2),?68,"Page ",RAPG
W !,"Procedure",?34,"Date/Time Changed",?55,"User",!?2,"Contrast Media"
W !,$$CJ^XLFSTR(RALINE,IOM)
Q
;
CONTRAST(RACMU) ;Return the current CM definition for this procedure delimited
;by commas.
;input: RACMU=internal value of CM; multiple CM references per string
; are possible
;return: the external format of CM delimited by commas
N RAI,RAX S RAX=""
F RAI=1:1:$L(RACMU) D
.S RAX=RAX_$$EXTERNAL^DILFD(71.0125,.01,"",$E(RACMU,RAI))_", "
.Q
Q $P(RAX,", ",1,($L(RAX,", ")-1)) ;strip off that last ", "
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACMHIS 4645 printed Dec 13, 2024@02:34:04 Page 2
RACMHIS ;HISC/GJC-Radiology Contrast Media History option (driver)
+1 ;;5.0;Radiology/Nuclear Medicine;**45**;Mar 16, 1998
+2 ;Note: new routine with the release of RA*5*45
+3 ;
EN ;begin; find all procedures with a CM audit history
+1 SET RADIC="^RAMIS(71,"
SET RADIC(0)="EMQZ"
SET RADIC("A")="Select Procedure: "
+2 SET RADIC("S")="I $O(^RAMIS(71,+Y,""AUD"",0))"
SET RAUTIL="RA PROC W/CM"
+3 KILL ^TMP($JOB,"RA PROC W/CM")
DO EN1^RASELCT(.RADIC,RAUTIL,"",1)
+4 IF $ORDER(^TMP($JOB,"RA PROC W/CM",""))=""
Begin DoDot:1
+5 WRITE !?3,"No procedures have been selected, exiting this option."
QUIT
End DoDot:1
DO KILL
QUIT
+6 ;
STRTDT ;Prompt for Starting Date
+1 WRITE !
KILL DIR
SET DIR(0)="DA^:"_DT_":PEA"
+2 SET DIR("A")="Enter the start date for the search: "
+3 SET DIR("?",1)="This is the date from which our search will begin."
+4 SET DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'FROM'."
+5 SET DIR("?",3)="The starting date must not exceed: "_$$FMTE^XLFDT(DT,"1P")_"."
+6 SET DIR("?")="Dates associated with a time will not be accepted."
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
DO KILL
QUIT
+9 ;int. date/time ^ ext. date/time ^ int. date/time minus one second
+10 SET RASTRT=Y_"^"_Y(0)_"^"_$$FMADD^XLFDT(Y,"","","",-1)
+11 ;
ENDDT ;Prompt for Ending Date
+1 WRITE !
KILL DIR
SET DIR(0)="DA^"_$PIECE(RASTRT,U)_":"_DT_":PEA"
+2 SET DIR("A")="Enter the ending date for the search: "
+3 SET DIR("?",1)="This is the date in which our search will end."
+4 SET DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'TO'."
+5 SET DIR("?",3)="The ending date must not exceed: "_$$FMTE^XLFDT(DT,"1P")_"."
+6 SET DIR("?",4)="The ending date must not precede: "_$PIECE(RASTRT,U,2)_"."
+7 SET DIR("?")="Dates associated with a time will not be accepted."
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO KILL
QUIT
+10 ;int. date/time ^ ext. date/time ^ int. date/time plus 23hrs, 59 min,
+11 ;& 59 seconds
+12 SET RASTOP=Y_"^"_Y(0)_"^"_(Y+.235959)
+13 ;
+14 FOR I="RASTRT","RASTOP","^TMP($J,"
SET ZTSAVE(I)=""
+15 KILL I
DO EN^XUTMDEVQ("START^RACMHIS","Rad/Nuc Med: Contrast Media History report",.ZTSAVE,,1)
+16 IF +$GET(ZTSK)>0
WRITE !!,"Task Number: "_ZTSK,!
+17 ;
KILL ;clean up symbol table
+1 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RADIC,RAQUIT,RASTOP,RASTRT,RAUTIL,X
+2 KILL Y,ZTSAVE,ZTSK,^TMP($JOB,"RA PROC W/CM")
+3 QUIT
+4 ;
START ;main body
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 SET RAHD="Contrast Media Edit History By Procedure"
+3 SET $PIECE(RALINE,"-",(IOM+1))=""
SET RAPG=0
SET RADT=$$FMTE^XLFDT(DT,"1P")
+4 ;clear screen
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 DO HDR
SET RAXIT=0
SET RAPNME=""
+6 FOR
SET RAPNME=$ORDER(^TMP($JOB,"RA PROC W/CM",RAPNME))
if RAPNME=""
QUIT
Begin DoDot:1
+7 SET RAXIT=$$S^%ZTLOAD()
if RAXIT
SET ZTSTOP=1
if RAXIT
QUIT
+8 SET RAY=0
+9 FOR
SET RAY=$ORDER(^TMP($JOB,"RA PROC W/CM",RAPNME,RAY))
if 'RAY
QUIT
Begin DoDot:2
+10 SET RAXIT=$$S^%ZTLOAD()
if RAXIT
SET ZTSTOP=1
if RAXIT
QUIT
+11 SET RAS=$PIECE(RASTRT,U,3)
+12 FOR
SET RAS=$ORDER(^RAMIS(71,RAY,"AUD","B",RAS))
if 'RAS!(RAS>$PIECE(RASTOP,U,3))
QUIT
Begin DoDot:3
+13 SET RAIEN=0
+14 FOR
SET RAIEN=$ORDER(^RAMIS(71,RAY,"AUD","B",RAS,RAIEN))
if 'RAIEN
QUIT
Begin DoDot:4
+15 ;get changed date/time, CM value, & user
+16 SET RAY(0)=$GET(^RAMIS(71,RAY,"AUD",RAIEN,0))
+17 SET RAADT=$$FMTE^XLFDT($PIECE(RAY(0),U),"1P")
SET RACMU=$PIECE(RAY(0),U,2)
+18 SET RAX=$SELECT($LENGTH(RACMU):$$CONTRAST(RACMU),1:"**User deleted all contrast media data**")
+19 if +$PIECE(RAY(0),U,3)
SET RAAU=$$GET1^DIQ(200,$PIECE(RAY(0),U,3)_",",.01)
+20 IF $Y>(IOSL-4)
DO EOS
if RAXIT
QUIT
+21 WRITE !,$EXTRACT(RAPNME,1,32),?33,RAADT,?55,$EXTRACT($GET(RAAU),1,24)
+22 IF $Y>(IOSL-4)
DO EOS
if RAXIT
QUIT
+23 ;display the past CM data value or that CM data has been deleted
+24 SET X=RAX
SET DIWL=3
SET DIWR=70
SET DIWF="W"
DO ^DIWP
DO ^DIWW
KILL ^UTILITY($JOB,"W")
+25 QUIT
End DoDot:4
if RAXIT
QUIT
+26 QUIT
End DoDot:3
if RAXIT
QUIT
+27 QUIT
End DoDot:2
if RAXIT
QUIT
+28 QUIT
End DoDot:1
if RAXIT
QUIT
EXIT ;clean up symbol table, message to user
+1 ;if there are no records to print, alert user
+2 if '$DATA(RAY(0))#2
WRITE !,$$CJ^XLFSTR("*** No Records To Print ***",IOM)
+3 KILL DIW,DIWF,DIWL,DIWR,DIWT,DN,I,RAADT,RAAU,RACMU,RADT,RAHD,RAI,RAIEN
+4 KILL RALINE,RAPG,RAPNME,RAS,RAXIT,RAX,RAY,X,Y,Z
+5 QUIT
+6 ;
EOS ; end of screen dialog
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 KILL DIR,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
SET RAXIT=1
+4 KILL DIR,DIRUT,DTOUT,DUOUT
+5 QUIT
End DoDot:1
if RAXIT
QUIT
+6 ;
+7 ;'falls' into HDR...
+8 ;
HDR ; print header
+1 if RAPG
WRITE @IOF
SET RAPG=RAPG+1
+2 WRITE !,$$CJ^XLFSTR(RAHD,IOM),!,"Run Date: ",RADT,?25,"From: ",$PIECE(RASTRT,U,2),?45,"To: ",$PIECE(RASTOP,U,2),?68,"Page ",RAPG
+3 WRITE !,"Procedure",?34,"Date/Time Changed",?55,"User",!?2,"Contrast Media"
+4 WRITE !,$$CJ^XLFSTR(RALINE,IOM)
+5 QUIT
+6 ;
CONTRAST(RACMU) ;Return the current CM definition for this procedure delimited
+1 ;by commas.
+2 ;input: RACMU=internal value of CM; multiple CM references per string
+3 ; are possible
+4 ;return: the external format of CM delimited by commas
+5 NEW RAI,RAX
SET RAX=""
+6 FOR RAI=1:1:$LENGTH(RACMU)
Begin DoDot:1
+7 SET RAX=RAX_$$EXTERNAL^DILFD(71.0125,.01,"",$EXTRACT(RACMU,RAI))_", "
+8 QUIT
End DoDot:1
+9 ;strip off that last ", "
QUIT $PIECE(RAX,", ",1,($LENGTH(RAX,", ")-1))
+10 ;
