RAMAINP1 ;HISC/GJC AISC/TMP,RMO-Utility Files Print ;9/22/98 15:26
;;5.0;Radiology/Nuclear Medicine;**3,45**;Mar 16, 1998
18 ;;Parent Procedure List
N RA1,RA2,RA3
D KILL^RAMAINP N RAX,RAY S RAX=$$IMG^RAUTL12() Q:'RAX
S RASTAT=$$ACTIVE()
I RASTAT="^" K RASTAT Q
S DIC="^RAMIS(71,",L=0,FLDS="[RA PARENT PROCEDURE LIST]"
S BY="12,.01",DHD=$S(RASTAT="B":"Active/Inactive",RASTAT="A":"Active",1:"Inactive")_" Parent Procedure List"
S:RASTAT="B" DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0)"
S:RASTAT="A" DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0),(+$G(^RAMIS(71,D0,""I""))=0!(+$G(^RAMIS(71,D0,""I""))>DT))"
S:RASTAT="I" DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0),+$G(^RAMIS(71,D0,""I""))>0,+$G(^RAMIS(71,D0,""I""))'>DT"
S (FR,TO)="" K RASTAT S DHIT="S $P(RALINE,""-"",(IOM+1))="""" W !,RALINE"
W ! D 132^RAMAINP S RAPOP=$$ZIS^RAMAINP("Rad/Nuc Med Parent Procedure Listing")
I +RAPOP D HOME^%ZIS,KILL^RAMAINP Q ; device selection failed
I +$P(RAPOP,"^",2) D KILL^RAMAINP Q
E D ENTASK^RAMAINP
Q
;
CMPRT ; Entry Point: print procedures that are associated with contrast
; media/medium.
; kill ^TMP($J) and select procedure i-types
K ^TMP($J,"RA I-TYPE") S RAX=$$IMG^RAUTL12() I 'RAX K RAX Q
S RAITYP="^",RAX=""
F S RAX=$O(^TMP($J,"RA I-TYPE",RAX)) Q:RAX="" D
.S RAY=$O(^TMP($J,"RA I-TYPE",RAX,0)),RAITYP=RAITYP_RAY_"^"
.K ^TMP($J,"RA I-TYPE",RAX)
.Q
; ask if active, inactive, or both active & inactive procedures are
; to be included.
S RASTAT=$$ACTIVE()
I RASTAT="^" K RAITYP,RASTAT,RAX,RAY Q
; save off user input parameters
F I="RAITYP","RASTAT" S ZTSAVE(I)=""
K I D EN^XUTMDEVQ("PRTCM^RAMAINP1","Rad/Nuc Med: print procedure contrast media association",.ZTSAVE,,1)
I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,!
K %L,%X,%Y,DDH,POP,RAITYP,RASTAT,RAX,RAY,X,Y,ZTSAVE,ZTSK
Q
;
PRTCM ; Print procedures that are associated with contrast media/medium.
S:$D(ZTQUEUED) ZTREQ="@"
S RAHD="Rad/Nuc Med Procedures with Contrast Media/Medium"
S RAHD=$S(RASTAT="A":"Active ",RASTAT="I":"Inactive ",1:"")_RAHD
S $P(RALINE,"-",(IOM+1))=""
S RAPG=0,RADT=$$FMTE^XLFDT(DT,"1P")
W:$E(IOST,1,2)="C-" @IOF ;clear screen
D HDR S (RAY,RAXIT)=0
;only want procedure with contrast media/medium associations
F S RAY=$O(^RAMIS(71,"CM","Y",RAY)) Q:'RAY D Q:RAXIT
.S RAXIT=$$S^%ZTLOAD() S:RAXIT ZTSTOP=1 Q:RAXIT
.S RAY(0)=$G(^RAMIS(71,RAY,0))
.;does the procedure have an i-type specified by the user?
.Q:RAITYP'[("^"_$P(RAY(0),U,12)_"^")
.S RAY("I")=+$G(^RAMIS(71,RAY,"I"))
.;if inactive proc are desired, and the inact. date is in the future
.;(the field will accept future dates), quit
.I RASTAT="I",RAY("I"),RAY("I")>DT Q
.;if inactive proc are desired, and no inact. date, quit
.I RASTAT="I",'RAY("I") Q
.;if active proc are desired, and the inact. date is today or in the
.;past, quit
.I RASTAT="A",RAY("I"),RAY("I")'>DT Q
.;if both inactive & active procedures are desired all records qualify
.W !!,$P($$NAMCODE^RACPTMSC($P(RAY(0),U,9),DT),U),?19,$P(RAY(0),U)
.I $Y>(IOSL-4) D EOS Q:RAXIT
.W ! S (RACM,RADCM)=.001
.F D Q:('RACM&'RADCM)!RAXIT W !
..S:RADCM RADCM=$O(^RAMIS(71,RAY,"DCM",RADCM)) W:RADCM ?2,$E($P($$BASICMOD^RACPTMSC(+$G(^(RADCM,0)),DT),U,3),1,47)
..S:RACM RACM=$O(^RAMIS(71,RAY,"CM",RACM)) W:RACM ?50,$$EXTERNAL^DILFD(71.0125,.01,"",$P($G(^(RACM,0)),U))
..I $Y>(IOSL-4) D EOS Q:RAXIT
..Q
.Q:RAXIT I $Y>(IOSL-4) D EOS
.W $$EXTERNAL^DILFD(71,6,"",$P(RAY(0),U,6)),?24,$$EXTERNAL^DILFD(71,12,"",$P(RAY(0),U,12))
.I RASTAT'="A",(RAY("I")>0) W ?52,$$EXTERNAL^DILFD(71,100,"",RAY("I"))
.Q
;
KILL ; kill and quit
;if there are no records to print, alert user
W:'$D(RAY(0))#2 !,$$CJ^XLFSTR("*** No Records To Print ***",IOM)
;
K RACM,RADCM,RADT,RAHD,RAITYP,RALINE,RAPG,RAXIT,RAY
Q
;
ACTIVE() ; Use the ^DIR call to ask the user if active, inactive, or
; both inactive & active procedures are to be included.
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X N Y
S DIR(0)="S^A:Active;I:Inactive;B:Both",DIR("A")="Select Procedure Status",DIR("B")="A"
S DIR("?",1)="Enter 'A' for active procedures, 'I' for inactive proceduRes,"
S DIR("?")="or 'B' for both active and inactive procedures."
W ! D ^DIR S:$D(DIRUT) Y="^"
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X
Q Y
;
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
;
HDR ; print header
W:RAPG @IOF S RAPG=RAPG+1
W !,$$CJ^XLFSTR(RAHD,IOM),!,"Date: ",RADT,?69,"Page ",RAPG
W !,"CPT",?19,"Procedure",!?2,"CPT Modifiers",?50,"Contrast Media",!,"Procedure Type",?24,"Imaging Type"
W:RASTAT'="A" ?52,"Inactivation Date"
W !,$$CJ^XLFSTR(RALINE,IOM)
Q
;
CMDISP(RAZ71) ;Display contrast media data for descendents when the 'Parent
;Procedure List' [RA PROCPARENT] option is exercised
;function called from print template: [RA PARENT PROCEDURE LIST]
;input-RAZ71 internal entry number of the descendent
;formatting issues; differ for print options
W !?7,"Contrast Medium"
N RALBL,RAX,RAY S (RALBL,RAY)=0
F S RAY=$O(^RAMIS(71,RAZ71,"CM",RAY)) Q:'RAY D
.S RAX=$P($G(^RAMIS(71,RAZ71,"CM",RAY,0)),U) ;RAX=CM value (internal)
.W:RALBL ! W ?40,$$EXTERNAL^DILFD(71.0125,.01,"",RAX) S RALBL=RAY
.Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAINP1 5387 printed Nov 22, 2024@17:47:16 Page 2
RAMAINP1 ;HISC/GJC AISC/TMP,RMO-Utility Files Print ;9/22/98 15:26
+1 ;;5.0;Radiology/Nuclear Medicine;**3,45**;Mar 16, 1998
18 ;;Parent Procedure List
+1 NEW RA1,RA2,RA3
+2 DO KILL^RAMAINP
NEW RAX,RAY
SET RAX=$$IMG^RAUTL12()
if 'RAX
QUIT
+3 SET RASTAT=$$ACTIVE()
+4 IF RASTAT="^"
KILL RASTAT
QUIT
+5 SET DIC="^RAMIS(71,"
SET L=0
SET FLDS="[RA PARENT PROCEDURE LIST]"
+6 SET BY="12,.01"
SET DHD=$SELECT(RASTAT="B":"Active/Inactive",RASTAT="A":"Active",1:"Inactive")_" Parent Procedure List"
+7 if RASTAT="B"
SET DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0)"
+8 if RASTAT="A"
SET DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0),(+$G(^RAMIS(71,D0,""I""))=0!(+$G(^RAMIS(71,D0,""I""))>DT))"
+9 if RASTAT="I"
SET DIS(0)="I $P($G(^RAMIS(71,D0,0)),U,6)=""P"",$$IMG^RAMAINP(D0),+$G(^RAMIS(71,D0,""I""))>0,+$G(^RAMIS(71,D0,""I""))'>DT"
+10 SET (FR,TO)=""
KILL RASTAT
SET DHIT="S $P(RALINE,""-"",(IOM+1))="""" W !,RALINE"
+11 WRITE !
DO 132^RAMAINP
SET RAPOP=$$ZIS^RAMAINP("Rad/Nuc Med Parent Procedure Listing")
+12 ; device selection failed
IF +RAPOP
DO HOME^%ZIS
DO KILL^RAMAINP
QUIT
+13 IF +$PIECE(RAPOP,"^",2)
DO KILL^RAMAINP
QUIT
+14 IF '$TEST
DO ENTASK^RAMAINP
+15 QUIT
+16 ;
CMPRT ; Entry Point: print procedures that are associated with contrast
+1 ; media/medium.
+2 ; kill ^TMP($J) and select procedure i-types
+3 KILL ^TMP($JOB,"RA I-TYPE")
SET RAX=$$IMG^RAUTL12()
IF 'RAX
KILL RAX
QUIT
+4 SET RAITYP="^"
SET RAX=""
+5 FOR
SET RAX=$ORDER(^TMP($JOB,"RA I-TYPE",RAX))
if RAX=""
QUIT
Begin DoDot:1
+6 SET RAY=$ORDER(^TMP($JOB,"RA I-TYPE",RAX,0))
SET RAITYP=RAITYP_RAY_"^"
+7 KILL ^TMP($JOB,"RA I-TYPE",RAX)
+8 QUIT
End DoDot:1
+9 ; ask if active, inactive, or both active & inactive procedures are
+10 ; to be included.
+11 SET RASTAT=$$ACTIVE()
+12 IF RASTAT="^"
KILL RAITYP,RASTAT,RAX,RAY
QUIT
+13 ; save off user input parameters
+14 FOR I="RAITYP","RASTAT"
SET ZTSAVE(I)=""
+15 KILL I
DO EN^XUTMDEVQ("PRTCM^RAMAINP1","Rad/Nuc Med: print procedure contrast media association",.ZTSAVE,,1)
+16 IF +$GET(ZTSK)>0
WRITE !!,"Task Number: "_ZTSK,!
+17 KILL %L,%X,%Y,DDH,POP,RAITYP,RASTAT,RAX,RAY,X,Y,ZTSAVE,ZTSK
+18 QUIT
+19 ;
PRTCM ; Print procedures that are associated with contrast media/medium.
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 SET RAHD="Rad/Nuc Med Procedures with Contrast Media/Medium"
+3 SET RAHD=$SELECT(RASTAT="A":"Active ",RASTAT="I":"Inactive ",1:"")_RAHD
+4 SET $PIECE(RALINE,"-",(IOM+1))=""
+5 SET RAPG=0
SET RADT=$$FMTE^XLFDT(DT,"1P")
+6 ;clear screen
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+7 DO HDR
SET (RAY,RAXIT)=0
+8 ;only want procedure with contrast media/medium associations
+9 FOR
SET RAY=$ORDER(^RAMIS(71,"CM","Y",RAY))
if 'RAY
QUIT
Begin DoDot:1
+10 SET RAXIT=$$S^%ZTLOAD()
if RAXIT
SET ZTSTOP=1
if RAXIT
QUIT
+11 SET RAY(0)=$GET(^RAMIS(71,RAY,0))
+12 ;does the procedure have an i-type specified by the user?
+13 if RAITYP'[("^"_$PIECE(RAY(0),U,12)_"^")
QUIT
+14 SET RAY("I")=+$GET(^RAMIS(71,RAY,"I"))
+15 ;if inactive proc are desired, and the inact. date is in the future
+16 ;(the field will accept future dates), quit
+17 IF RASTAT="I"
IF RAY("I")
IF RAY("I")>DT
QUIT
+18 ;if inactive proc are desired, and no inact. date, quit
+19 IF RASTAT="I"
IF 'RAY("I")
QUIT
+20 ;if active proc are desired, and the inact. date is today or in the
+21 ;past, quit
+22 IF RASTAT="A"
IF RAY("I")
IF RAY("I")'>DT
QUIT
+23 ;if both inactive & active procedures are desired all records qualify
+24 WRITE !!,$PIECE($$NAMCODE^RACPTMSC($PIECE(RAY(0),U,9),DT),U),?19,$PIECE(RAY(0),U)
+25 IF $Y>(IOSL-4)
DO EOS
if RAXIT
QUIT
+26 WRITE !
SET (RACM,RADCM)=.001
+27 FOR
Begin DoDot:2
+28 if RADCM
SET RADCM=$ORDER(^RAMIS(71,RAY,"DCM",RADCM))
if RADCM
WRITE ?2,$EXTRACT($PIECE($$BASICMOD^RACPTMSC(+$GET(^(RADCM,0)),DT),U,3),1,47)
+29 if RACM
SET RACM=$ORDER(^RAMIS(71,RAY,"CM",RACM))
if RACM
WRITE ?50,$$EXTERNAL^DILFD(71.0125,.01,"",$PIECE($GET(^(RACM,0)),U))
+30 IF $Y>(IOSL-4)
DO EOS
if RAXIT
QUIT
+31 QUIT
End DoDot:2
if ('RACM&'RADCM)!RAXIT
QUIT
WRITE !
+32 if RAXIT
QUIT
IF $Y>(IOSL-4)
DO EOS
+33 WRITE $$EXTERNAL^DILFD(71,6,"",$PIECE(RAY(0),U,6)),?24,$$EXTERNAL^DILFD(71,12,"",$PIECE(RAY(0),U,12))
+34 IF RASTAT'="A"
IF (RAY("I")>0)
WRITE ?52,$$EXTERNAL^DILFD(71,100,"",RAY("I"))
+35 QUIT
End DoDot:1
if RAXIT
QUIT
+36 ;
KILL ; kill and quit
+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 ;
+4 KILL RACM,RADCM,RADT,RAHD,RAITYP,RALINE,RAPG,RAXIT,RAY
+5 QUIT
+6 ;
ACTIVE() ; Use the ^DIR call to ask the user if active, inactive, or
+1 ; both inactive & active procedures are to be included.
+2 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X
NEW Y
+3 SET DIR(0)="S^A:Active;I:Inactive;B:Both"
SET DIR("A")="Select Procedure Status"
SET DIR("B")="A"
+4 SET DIR("?",1)="Enter 'A' for active procedures, 'I' for inactive proceduRes,"
+5 SET DIR("?")="or 'B' for both active and inactive procedures."
+6 WRITE !
DO ^DIR
if $DATA(DIRUT)
SET Y="^"
+7 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X
+8 QUIT Y
+9 ;
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 ;
HDR ; print header
+1 if RAPG
WRITE @IOF
SET RAPG=RAPG+1
+2 WRITE !,$$CJ^XLFSTR(RAHD,IOM),!,"Date: ",RADT,?69,"Page ",RAPG
+3 WRITE !,"CPT",?19,"Procedure",!?2,"CPT Modifiers",?50,"Contrast Media",!,"Procedure Type",?24,"Imaging Type"
+4 if RASTAT'="A"
WRITE ?52,"Inactivation Date"
+5 WRITE !,$$CJ^XLFSTR(RALINE,IOM)
+6 QUIT
+7 ;
CMDISP(RAZ71) ;Display contrast media data for descendents when the 'Parent
+1 ;Procedure List' [RA PROCPARENT] option is exercised
+2 ;function called from print template: [RA PARENT PROCEDURE LIST]
+3 ;input-RAZ71 internal entry number of the descendent
+4 ;formatting issues; differ for print options
+5 WRITE !?7,"Contrast Medium"
+6 NEW RALBL,RAX,RAY
SET (RALBL,RAY)=0
+7 FOR
SET RAY=$ORDER(^RAMIS(71,RAZ71,"CM",RAY))
if 'RAY
QUIT
Begin DoDot:1
+8 ;RAX=CM value (internal)
SET RAX=$PIECE($GET(^RAMIS(71,RAZ71,"CM",RAY,0)),U)
+9 if RALBL
WRITE !
WRITE ?40,$$EXTERNAL^DILFD(71.0125,.01,"",RAX)
SET RALBL=RAY
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
