- RAPINFO ;HIRMFO/GJC - Display Imaging Procedure Rad/Nuc Med info ;11/5/99 12:32
- ;;5.0;Radiology/Nuclear Medicine;**10,45**;Mar 16, 1998
- EN1 ; Associated option: [DISPLAY IMAGING PROCEDURE RAD/NUC MED INFORMATION]
- N RADIC,RAINA,RAITYPE,RAQUIT,RAUTIL
- K ^TMP($J,"RA PROCEDURES") W !
- S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
- S DIC("W")="D DICW^RAPINFO"
- S DIC("S")="I ($D(^RAMIS(71,""AIMG"",+Y))\10)"
- D ^DIC K DIC
- I Y'>0 D KILL Q
- S RAITYPE=Y ; 'RAITYPE' = ien of entry in 79.2 ^ .01 value in 79.2
- ;
- PROC ; Procedure selection O-M-A
- S RADIC="^RAMIS(71,",RADIC("A")="Select a Rad/Nuc Med Procedure: "
- S RADIC(0)="QEANMZ",RADIC("S")="I $$DICS^RAPINFO(RAITYPE,+Y)"
- S RAUTIL="RA PROCEDURES" D EN1^RASELCT(.RADIC,RAUTIL)
- I '($D(^TMP($J,"RA PROCEDURES"))\10) D KILL Q ; quit, nothing selected
- DEV ; Device selection
- W ! S %ZIS="QM",%ZIS("A")="Select a Device: " D ^%ZIS W !
- I POP K %ZIS D KILL Q
- I $D(IO("Q")) D D KILL Q
- . S ZTRTN="START^RAPINFO"
- . S ZTSAVE("^TMP($J,""RA PROCEDURES"",")=""
- . S ZTDESC="Rad/Nuc Med Display Imaging Procedure information"
- . D ^%ZTLOAD
- . I +$G(ZTSK("D"))>0 D
- .. W !?5,"Request Queued, Task #: ",+$G(ZTSK)
- .. Q
- . E W !?5,"Request cancelled!"
- . D HOME^%ZIS K IO("Q")
- . Q
- START ; Start processing data & printing to the device here.
- S:$D(ZTQUEUED) ZTREQ="@"
- U IO N I,J,RA0,RA1,RA2,RA71,RADD,RAHDR,RAIDFIER,RALN,RAMAX,RANOW,RAPG
- N RARUNDT,RAXIT S RA0="",(RAMAX,RAPG,RAXIT)=0
- S RAHDR="Radiology/Nuclear Medicine Procedure Information"
- S $P(RALN,"-",(IOM+1))=""
- S RADD=$P($G(^DD(71,6,0)),"^",3)
- F I=1:1:$L(RADD,";") S J=$P($P(RADD,";",I),":",2) Q:J']"" D
- . S:$L(J)>RAMAX RAMAX=$L(J)
- . Q
- S RANOW=$$NOW^XLFDT(),RANOW=$P(RANOW,".")_"."_$E($P(RANOW,".",2),1,4)
- S RARUNDT=$$FMTE^XLFDT(RANOW,"1P") D HDR^RAPINFO G:RAXIT KILL
- F S RA0=$O(^TMP($J,"RA PROCEDURES",RA0)) Q:RA0="" D Q:RAXIT
- . S RA1=0
- . F S RA1=$O(^TMP($J,"RA PROCEDURES",RA0,RA1)) Q:RA1'>0 D Q:RAXIT
- .. S RA71=$G(^RAMIS(71,RA1,0)) Q:RA71']""
- .. S RAIDFIER=$$BLD^RAPINFO(RA1)
- .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
- .. Q:RAXIT W !,$E(RA0,1,30),?34,RAIDFIER
- ..;
- ..;check if the descendents have CM relations
- ..I $P(RA71,U,6)="P" D Q:RAXIT
- ...S RA2=0 F S RA2=$O(^RAMIS(71,RA1,4,RA2)) Q:'RA2 D Q:RAXIT
- ....S RA21=+$G(^RAMIS(71,RA1,4,RA2,0)) D DESC(RA21,"P")
- ....Q
- ...K RA2,RA21 Q
- ..;
- ..;check if the non-parent has CM relations
- ..E D:$O(^RAMIS(71,RA1,"CM",0)) DESC(RA1,"") Q:RAXIT
- ..;
- .. I $O(^RAMIS(71,RA1,"EDU",0)) D
- ... S DIWF="W",DIWL=1,DIWR=$S(IOM=132:100,1:76)
- ... S RA2=0 K ^UTILITY($J,"W") S X="Educational Desc: "
- ... F S RA2=$O(^RAMIS(71,RA1,"EDU",RA2)) Q:RA2'>0 D K X Q:RAXIT
- .... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
- .... Q:RAXIT S X=$G(X)_$G(^RAMIS(71,RA1,"EDU",RA2,0)) Q:X']"" D ^DIWP
- .... Q
- ... D:'RAXIT ^DIWW ; *** procedure message text to be printed
- ... Q ; *** once procedure messages are changed to WP
- .. E W ! ; *** from pointers to 71.4 ***
- .. Q
- . Q
- W ! D ^%ZISC,KILL
- Q
- BLD(RA1) ; Build procedure identifier string
- ; input: 'RA1' = ien of entry in Rad/Nuc Med Procedures file
- N RA,RACPT,RAIABRV,RAPTYPE,RASTR S RASTR="("
- S RA(0)=$G(^RAMIS(71,RA1,0)),RA("I")=$G(^RAMIS(71,RA1,"I"))
- S RAIABRV(0)=+$P(RA(0),"^",12)
- S RAIABRV(1)=$P($G(^RA(79.2,RAIABRV(0),0)),"^",3)
- S RAIABRV=$S(RAIABRV(1)]"":RAIABRV(1),1:"Unknown")
- I RA("I"),(RA("I")'>DT) S RAPTYPE="Inactive"
- I $D(RAPTYPE)[0 D
- . S RAPTYPE=$$XTERNAL^RAUTL5($P(RA(0),"^",6),$P($G(^DD(71,6,0)),"^",2))
- . S RAPTYPE=$E(RAPTYPE)_$$LOW^XLFSTR($E(RAPTYPE,2,99999))
- . S:RAPTYPE']"" RAPTYPE="Unknown"
- . Q
- S:$L(RAPTYPE)<RAMAX RAPTYPE=RAPTYPE_$E(" ",1,(RAMAX-$L(RAPTYPE)))
- S RACPT(0)=+$P(RA(0),"^",9) S:'RACPT(0) RACPT="Unknown"
- S:$E(RAPTYPE)="P" RACPT="See Descendents"
- I '($D(RACPT)#2) D
- . S RACPT=$P($$NAMCODE^RACPTMSC(RACPT(0),DT),"^")
- . S:RACPT="" RACPT="Unknown"
- . Q
- S RASTR=RASTR_RAIABRV_" "_RAPTYPE_") CPT:"_RACPT
- Q RASTR
- ;
- DICS(RAY,Y) ; Display active procedures within an imaging type.
- ; Input : RAY - Imaging Type
- ; Y - ien of the procedure
- ; Output: 1 if a valid selection, 0 if invalid
- Q:'$D(^RAMIS(71,"AIMG",+RAITYPE,+Y))#2 0 ; not valid, wrong i-type
- N RA71ACT S RA71ACT=$G(^RAMIS(71,+Y,"I"))
- Q $S(RA71ACT="":1,RA71ACT>DT:1,1:0)
- ;
- DICW ; Display abbreviation with the I-Type
- N RA792,RABBRV
- S RA792=$G(^RA(79.2,+Y,0)),RABBRV=$P(RA792,"^",3)
- S RABBRV(1)=$S(RABBRV]"":" "_RABBRV,1:" Unknown")
- S RABBRV(1,"F")="?0" D EN^DDIOL(.RABBRV)
- Q
- HDR ; Header for our report
- W:$Y @IOF S RAPG=RAPG+1
- W !?(IOM-$L(RAHDR)\2),RAHDR
- W !!,"Run Date/Time: ",RARUNDT,?($S(IOM=132:121,1:68)),"Page: ",RAPG
- W !,RALN
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
- Q
- KILL ; Kill and quit the application
- K ^TMP($J,"RA PROCEDURES"),%X,%XX,%Y,%YY
- K C,DDH,DIROUT,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DN,DTOUT,DUOUT,X,Y
- K Z,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS
- Q
- ;
- DESC(RAPRC,RAFLG) ; display the descendants associated with the
- ; parent procedure
- ;input: RAPRC-IEN of the procedure in the Rad/Nuc Med Procedure file
- ; RAFLG-indicates procedure type; "P" if parent, else null
- I RAFLG="P" D Q:RAXIT
- .S RAIDFIER=$$BLD^RAPINFO(RAPRC)
- .I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
- .Q:RAXIT W:$X ! W ?2,$E($P($G(^RAMIS(71,RAPRC,0)),U),1,30),?34,RAIDFIER
- .Q
- Q:+$O(^RAMIS(71,RAPRC,"CM",0))=0
- CMEDIA ; display the contrast media associated with the parent procedure
- K X,^UTILITY($J,"W") S RA3=0,X="Contrast Media: "
- S DIWF="W",DIWL=3,DIWR=$S(IOM=132:100,1:76)
- F S RA3=$O(^RAMIS(71,RAPRC,"CM",RA3)) Q:RA3'>0 D
- .S RA3(0)=$P($G(^RAMIS(71,RAPRC,"CM",RA3,0)),U)
- .S X=X_$$EXTERNAL^DILFD(71.0125,.01,"",RA3(0))_", "
- .Q
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
- S X=$P(X,", ",1,$L(X,", ")-1) D ^DIWP,^DIWW
- K ^UTILITY($J,"W"),DIWF,DIWL,DIWR,RA3,X
- Q
- ;
- RAPINFO ;HIRMFO/GJC - Display Imaging Procedure Rad/Nuc Med info ;11/5/99 12:32
- +1 ;;5.0;Radiology/Nuclear Medicine;**10,45**;Mar 16, 1998
- EN1 ; Associated option: [DISPLAY IMAGING PROCEDURE RAD/NUC MED INFORMATION]
- +1 NEW RADIC,RAINA,RAITYPE,RAQUIT,RAUTIL
- +2 KILL ^TMP($JOB,"RA PROCEDURES")
- WRITE !
- +3 SET DIC="^RA(79.2,"
- SET DIC(0)="QEAMNZ"
- SET DIC("A")="Select an Imaging Type: "
- +4 SET DIC("W")="D DICW^RAPINFO"
- +5 SET DIC("S")="I ($D(^RAMIS(71,""AIMG"",+Y))\10)"
- +6 DO ^DIC
- KILL DIC
- +7 IF Y'>0
- DO KILL
- QUIT
- +8 ; 'RAITYPE' = ien of entry in 79.2 ^ .01 value in 79.2
- SET RAITYPE=Y
- +9 ;
- PROC ; Procedure selection O-M-A
- +1 SET RADIC="^RAMIS(71,"
- SET RADIC("A")="Select a Rad/Nuc Med Procedure: "
- +2 SET RADIC(0)="QEANMZ"
- SET RADIC("S")="I $$DICS^RAPINFO(RAITYPE,+Y)"
- +3 SET RAUTIL="RA PROCEDURES"
- DO EN1^RASELCT(.RADIC,RAUTIL)
- +4 ; quit, nothing selected
- IF '($DATA(^TMP($JOB,"RA PROCEDURES"))\10)
- DO KILL
- QUIT
- DEV ; Device selection
- +1 WRITE !
- SET %ZIS="QM"
- SET %ZIS("A")="Select a Device: "
- DO ^%ZIS
- WRITE !
- +2 IF POP
- KILL %ZIS
- DO KILL
- QUIT
- +3 IF $DATA(IO("Q"))
- Begin DoDot:1
- +4 SET ZTRTN="START^RAPINFO"
- +5 SET ZTSAVE("^TMP($J,""RA PROCEDURES"",")=""
- +6 SET ZTDESC="Rad/Nuc Med Display Imaging Procedure information"
- +7 DO ^%ZTLOAD
- +8 IF +$GET(ZTSK("D"))>0
- Begin DoDot:2
- +9 WRITE !?5,"Request Queued, Task #: ",+$GET(ZTSK)
- +10 QUIT
- End DoDot:2
- +11 IF '$TEST
- WRITE !?5,"Request cancelled!"
- +12 DO HOME^%ZIS
- KILL IO("Q")
- +13 QUIT
- End DoDot:1
- DO KILL
- QUIT
- START ; Start processing data & printing to the device here.
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 USE IO
- NEW I,J,RA0,RA1,RA2,RA71,RADD,RAHDR,RAIDFIER,RALN,RAMAX,RANOW,RAPG
- +3 NEW RARUNDT,RAXIT
- SET RA0=""
- SET (RAMAX,RAPG,RAXIT)=0
- +4 SET RAHDR="Radiology/Nuclear Medicine Procedure Information"
- +5 SET $PIECE(RALN,"-",(IOM+1))=""
- +6 SET RADD=$PIECE($GET(^DD(71,6,0)),"^",3)
- +7 FOR I=1:1:$LENGTH(RADD,";")
- SET J=$PIECE($PIECE(RADD,";",I),":",2)
- IF J']""
- QUIT
- Begin DoDot:1
- +8 IF $LENGTH(J)>RAMAX
- SET RAMAX=$LENGTH(J)
- +9 QUIT
- End DoDot:1
- +10 SET RANOW=$$NOW^XLFDT()
- SET RANOW=$PIECE(RANOW,".")_"."_$EXTRACT($PIECE(RANOW,".",2),1,4)
- +11 SET RARUNDT=$$FMTE^XLFDT(RANOW,"1P")
- DO HDR^RAPINFO
- IF RAXIT
- GOTO KILL
- +12 FOR
- SET RA0=$ORDER(^TMP($JOB,"RA PROCEDURES",RA0))
- IF RA0=""
- QUIT
- Begin DoDot:1
- +13 SET RA1=0
- +14 FOR
- SET RA1=$ORDER(^TMP($JOB,"RA PROCEDURES",RA0,RA1))
- IF RA1'>0
- QUIT
- Begin DoDot:2
- +15 SET RA71=$GET(^RAMIS(71,RA1,0))
- IF RA71']""
- QUIT
- +16 SET RAIDFIER=$$BLD^RAPINFO(RA1)
- +17 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- DO HDR^RAPINFO
- +18 IF RAXIT
- QUIT
- WRITE !,$EXTRACT(RA0,1,30),?34,RAIDFIER
- +19 ;
- +20 ;check if the descendents have CM relations
- +21 IF $PIECE(RA71,U,6)="P"
- Begin DoDot:3
- +22 SET RA2=0
- FOR
- SET RA2=$ORDER(^RAMIS(71,RA1,4,RA2))
- IF 'RA2
- QUIT
- Begin DoDot:4
- +23 SET RA21=+$GET(^RAMIS(71,RA1,4,RA2,0))
- DO DESC(RA21,"P")
- +24 QUIT
- End DoDot:4
- IF RAXIT
- QUIT
- +25 KILL RA2,RA21
- QUIT
- End DoDot:3
- IF RAXIT
- QUIT
- +26 ;
- +27 ;check if the non-parent has CM relations
- +28 IF '$TEST
- IF $ORDER(^RAMIS(71,RA1,"CM",0))
- DO DESC(RA1,"")
- IF RAXIT
- QUIT
- +29 ;
- +30 IF $ORDER(^RAMIS(71,RA1,"EDU",0))
- Begin DoDot:3
- +31 SET DIWF="W"
- SET DIWL=1
- SET DIWR=$SELECT(IOM=132:100,1:76)
- +32 SET RA2=0
- KILL ^UTILITY($JOB,"W")
- SET X="Educational Desc: "
- +33 FOR
- SET RA2=$ORDER(^RAMIS(71,RA1,"EDU",RA2))
- IF RA2'>0
- QUIT
- Begin DoDot:4
- +34 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- DO HDR^RAPINFO
- +35 IF RAXIT
- QUIT
- SET X=$GET(X)_$GET(^RAMIS(71,RA1,"EDU",RA2,0))
- IF X']""
- QUIT
- DO ^DIWP
- +36 QUIT
- End DoDot:4
- KILL X
- IF RAXIT
- QUIT
- +37 ; *** procedure message text to be printed
- IF 'RAXIT
- DO ^DIWW
- +38 ; *** once procedure messages are changed to WP
- QUIT
- End DoDot:3
- +39 ; *** from pointers to 71.4 ***
- IF '$TEST
- WRITE !
- +40 QUIT
- End DoDot:2
- IF RAXIT
- QUIT
- +41 QUIT
- End DoDot:1
- IF RAXIT
- QUIT
- +42 WRITE !
- DO ^%ZISC
- DO KILL
- +43 QUIT
- BLD(RA1) ; Build procedure identifier string
- +1 ; input: 'RA1' = ien of entry in Rad/Nuc Med Procedures file
- +2 NEW RA,RACPT,RAIABRV,RAPTYPE,RASTR
- SET RASTR="("
- +3 SET RA(0)=$GET(^RAMIS(71,RA1,0))
- SET RA("I")=$GET(^RAMIS(71,RA1,"I"))
- +4 SET RAIABRV(0)=+$PIECE(RA(0),"^",12)
- +5 SET RAIABRV(1)=$PIECE($GET(^RA(79.2,RAIABRV(0),0)),"^",3)
- +6 SET RAIABRV=$SELECT(RAIABRV(1)]"":RAIABRV(1),1:"Unknown")
- +7 IF RA("I")
- IF (RA("I")'>DT)
- SET RAPTYPE="Inactive"
- +8 IF $DATA(RAPTYPE)[0
- Begin DoDot:1
- +9 SET RAPTYPE=$$XTERNAL^RAUTL5($PIECE(RA(0),"^",6),$PIECE($GET(^DD(71,6,0)),"^",2))
- +10 SET RAPTYPE=$EXTRACT(RAPTYPE)_$$LOW^XLFSTR($EXTRACT(RAPTYPE,2,99999))
- +11 IF RAPTYPE']""
- SET RAPTYPE="Unknown"
- +12 QUIT
- End DoDot:1
- +13 IF $LENGTH(RAPTYPE)<RAMAX
- SET RAPTYPE=RAPTYPE_$EXTRACT(" ",1,(RAMAX-$LENGTH(RAPTYPE)))
- +14 SET RACPT(0)=+$PIECE(RA(0),"^",9)
- IF 'RACPT(0)
- SET RACPT="Unknown"
- +15 IF $EXTRACT(RAPTYPE)="P"
- SET RACPT="See Descendents"
- +16 IF '($DATA(RACPT)#2)
- Begin DoDot:1
- +17 SET RACPT=$PIECE($$NAMCODE^RACPTMSC(RACPT(0),DT),"^")
- +18 IF RACPT=""
- SET RACPT="Unknown"
- +19 QUIT
- End DoDot:1
- +20 SET RASTR=RASTR_RAIABRV_" "_RAPTYPE_") CPT:"_RACPT
- +21 QUIT RASTR
- +22 ;
- DICS(RAY,Y) ; Display active procedures within an imaging type.
- +1 ; Input : RAY - Imaging Type
- +2 ; Y - ien of the procedure
- +3 ; Output: 1 if a valid selection, 0 if invalid
- +4 ; not valid, wrong i-type
- IF '$DATA(^RAMIS(71,"AIMG",+RAITYPE,+Y))#2
- QUIT 0
- +5 NEW RA71ACT
- SET RA71ACT=$GET(^RAMIS(71,+Y,"I"))
- +6 QUIT $SELECT(RA71ACT="":1,RA71ACT>DT:1,1:0)
- +7 ;
- DICW ; Display abbreviation with the I-Type
- +1 NEW RA792,RABBRV
- +2 SET RA792=$GET(^RA(79.2,+Y,0))
- SET RABBRV=$PIECE(RA792,"^",3)
- +3 SET RABBRV(1)=$SELECT(RABBRV]"":" "_RABBRV,1:" Unknown")
- +4 SET RABBRV(1,"F")="?0"
- DO EN^DDIOL(.RABBRV)
- +5 QUIT
- HDR ; Header for our report
- +1 IF $Y
- WRITE @IOF
- SET RAPG=RAPG+1
- +2 WRITE !?(IOM-$LENGTH(RAHDR)\2),RAHDR
- +3 WRITE !!,"Run Date/Time: ",RARUNDT,?($SELECT(IOM=132:121,1:68)),"Page: ",RAPG
- +4 WRITE !,RALN
- +5 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- IF $GET(ZTSTOP)=1
- SET RAXIT=1
- +6 QUIT
- KILL ; Kill and quit the application
- +1 KILL ^TMP($JOB,"RA PROCEDURES"),%X,%XX,%Y,%YY
- +2 KILL C,DDH,DIROUT,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DN,DTOUT,DUOUT,X,Y
- +3 KILL Z,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS
- +4 QUIT
- +5 ;
- DESC(RAPRC,RAFLG) ; display the descendants associated with the
- +1 ; parent procedure
- +2 ;input: RAPRC-IEN of the procedure in the Rad/Nuc Med Procedure file
- +3 ; RAFLG-indicates procedure type; "P" if parent, else null
- +4 IF RAFLG="P"
- Begin DoDot:1
- +5 SET RAIDFIER=$$BLD^RAPINFO(RAPRC)
- +6 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- DO HDR^RAPINFO
- +7 IF RAXIT
- QUIT
- IF $X
- WRITE !
- WRITE ?2,$EXTRACT($PIECE($GET(^RAMIS(71,RAPRC,0)),U),1,30),?34,RAIDFIER
- +8 QUIT
- End DoDot:1
- IF RAXIT
- QUIT
- +9 IF +$ORDER(^RAMIS(71,RAPRC,"CM",0))=0
- QUIT
- CMEDIA ; display the contrast media associated with the parent procedure
- +1 KILL X,^UTILITY($JOB,"W")
- SET RA3=0
- SET X="Contrast Media: "
- +2 SET DIWF="W"
- SET DIWL=3
- SET DIWR=$SELECT(IOM=132:100,1:76)
- +3 FOR
- SET RA3=$ORDER(^RAMIS(71,RAPRC,"CM",RA3))
- IF RA3'>0
- QUIT
- Begin DoDot:1
- +4 SET RA3(0)=$PIECE($GET(^RAMIS(71,RAPRC,"CM",RA3,0)),U)
- +5 SET X=X_$$EXTERNAL^DILFD(71.0125,.01,"",RA3(0))_", "
- +6 QUIT
- End DoDot:1
- +7 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- DO HDR^RAPINFO
- +8 SET X=$PIECE(X,", ",1,$LENGTH(X,", ")-1)
- DO ^DIWP
- DO ^DIWW
- +9 KILL ^UTILITY($JOB,"W"),DIWF,DIWL,DIWR,RA3,X
- +10 QUIT
- +11 ;
