RAPRI ;HISC/CAH,GJC AISC/DMK-Display Common Procedures ;3/12/98 11:26
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DISP ;Display list of common procedures - called from RAORD1
W ! D EN1^RAUTL17 S RAIMGTYI=Y G:RAIMGTYI'>0 DISPQ
DISP1 I '$O(^RAMIS(71.3,"AA",RAIMGTYI,0)) S RACNT=0 G DISPQ
D HOME^%ZIS W @IOF
S X="COMMON RADIOLOGY/NUCLEAR MEDICINE PROCEDURES ("_$P($G(^RA(79.2,RAIMGTYI,0)),U)_")" W !?80-$L(X)\2,X,!?80-$L(X)\2,$TR($J("",$L(X))," ","-")
S II=0 F I=1:1:40 S RAPRC(I)=""
D TOTAL
F I=1:1:RASEQ W:RAPRC(I)]"" !?1,I,") ",$P(RAPRC(I),"^") I RAPRC(I+RASEQ)]"" W ?44,(I+RASEQ),") ",$P(RAPRC(I+RASEQ),"^")
DISPQ K I,II,RASEQ,DISYS,POP
Q
LOOKUP ;Lookup procedure - called from RAORD1
;If user enters the sequential number on the common procedure list,
;the only screening done takes place when the procedure is stuffed
;in the input template. If user enters the name or CPT of a procedure
;at the prompt, additional screening takes place. Common procedures
;are not division-specific, so there is no way of stopping adpac's
;from using 'Broad' procedures on a common list.
I X?1.2N,+X=X,X'>RACNT S Y=$P($G(RAPRC(X)),"^",2) S:'$$BROAD() Y=-1 G Q
N DIC,Y W ! S DIC(0)="EQMZ",DIC="^RAMIS(71,"
S DIC("S")="N RAI,RA0 S RAI=$G(^(""I"")),RA0=$G(^(0)) I $S('RAI:1,DT'>RAI:1,1:0),$P(RA0,U,12)=RAIMGTYI,$S($P(RA0,U,6)=""P"":$O(^RAMIS(71,+Y,4,0)),1:1)"
S DIC("S")=DIC("S")_",$$BROAD^RAPRI()"
D ^DIC K DIC("S") S:X=""!(X="^") Y=-1
Q S (RAPRI,X)=+Y,RAPRI("X")=$P($G(^RAMIS(71,RAPRI,0)),"^")
I X>0 D Q:RAPRI'>0 ;GJC@12/27/93 modified GJC@2-26-96
. I $O(^RAMIS(71,RAPRI,3,0))!($O(^RAMIS(71,RAPRI,"EDU",0))) D EN2
. S RAS3=RADFN
. D ORDPRC1^RAUTL2
. Q
Q:RAPRI>0 S RAREASK=1 W !!,*7,"Unable to process this request due to an invalid procedure.",! I $P(RARX,",",(RAJ+1))="" R X:3 Q
S DIR(0)="Y",DIR("A")="Continue processing remaining input" D ^DIR K DIR S:Y'=1 RAOUT=1 Q
HELP ; Called from ADDORD1^RAORD1
I $E(RARX,1,2)="??" D
. ; display screened entries from Rad/Nuc Med Procedure file
. N D,DIC,DZ,RADIC S D="B"
. S RADIC("S")="N RA S RA(0)=$G(^(0)),RA(""I"")=$G(^RAMIS(71,+Y,""I""))"
. S RADIC("S1")=" I $P(RA(0),U,12)=RAIMGTYI,('RA(""I"")!(DT<RA(""I"")))"
. S DIC="^RAMIS(71,",DIC(0)="Q",DIC("S")=RADIC("S")_RADIC("S1"),DZ="??"
. S DIC("W")="W "" "",?54,$$PRCCPT^RADD1()" D DQ^DICQ
. Q
W !!?2,"To select a commonly ordered procedure, enter a number from the display above."
W !!?2,"To select procedures other than those listed above, enter the procedure name,",!?2,"synonym, or CPT number.",!!?2,"You may enter a single procedure or multiple procedures separated by commas."
W !?2,"To see a list of all selectable procedures, enter '??'.",!
S DIR(0)="E" D ^DIR K DIR
Q
EN2 ;Rad/Nuc Med Procedure Message Display
; Quit if you've seen these messages before. Value altered in the
; following routines: ADDORD+1^RAORD1 & DISP+12^RAORDU1
;ATTENTION: This code must be parallel to code in PROGMSG^RAUTL5
Q:+$G(RASTOP) S RASTOP=1
N RAXIT S RAXIT="" W:$Y @IOF
I $O(^RAMIS(71,RAPRI,3,0)) D
. N I,RAX,X S I=0
. W !!,*7,"NOTE: The following special requirements apply to this procedure: ",RAPRI("X"),!
. F S I=$O(^RAMIS(71,RAPRI,3,I)) Q:I'>0 D Q:RAXIT="^"
.. S RAX=+$G(^RAMIS(71,RAPRI,3,I,0))
.. I $D(^RAMIS(71.4,+RAX,0)) D
... I $Y>(IOSL-6) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
... S X=$G(^RAMIS(71.4,+RAX,0)) W !,X
... Q
.. Q
. Q
I $O(^RAMIS(71,RAPRI,"EDU",0)),($$UP^XLFSTR($P($G(^RAMIS(71,RAPRI,0)),"^",17))="Y") D
. W:+$O(^RAMIS(71,+RAPRI,3,0))>0 !!
. N DIW,DIWF,DIWL,DIWR,RAX,X
. K ^UTILITY($J,"W") S DIWF="W",DIWL=1,DIWR=75,RAX=0
. F S RAX=$O(^RAMIS(71,RAPRI,"EDU",RAX)) Q:RAX'>0 D Q:RAXIT="^"
.. I $Y>(IOSL-4) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
.. S X=$G(^RAMIS(71,RAPRI,"EDU",RAX,0)) D ^DIWP
.. Q
. Q:RAXIT="^"
. I $Y>(IOSL-4) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
. Q:RAXIT="^" D ^DIWW
. Q
Q:RAXIT="^"
W ! I $G(DR)="[RA QUICK EXAM ORDER]"!(($Y+5)>IOSL) W !,"Press RETURN to continue" R RAJUNK:DTIME K RAJUNK
Q
;
TOTAL N I,J,K,L
S (I,K,L,RACNT)=0
F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I>40!('I) S RACNT=I F S K=$O(^(I,K)) Q:'K I $D(^RAMIS(71.3,K,0)) S RAPRC(I)=$E($P($G(^RAMIS(71,+^(0),0)),"^"),1,32)_"^"_$P(^RAMIS(71.3,K,0),"^")
S RASEQ=$S(RACNT<40:(RACNT\2),1:20)
I RACNT#2 S RASEQ=RASEQ+1
Q
GET(DA) ;Get the IEN for the procedure. Used in input transform
;file 75.1 (Rad/Nuc Med Orders), field 125 (Modifiers).CEW
Q +$P($G(^RAO(75.1,DA,0)),U,2)
EOS() ; End of screen message, 'Press return to continue'
N X
I $D(RAPKG) D ; entered through Rad/Nuc Med
. R !!?5,"Press return to continue ",X:DTIME S:'$T X="^"
. Q
E D
. D READ^ORUTL S:'$T X="^"
. Q
Q $S($E(X)="^":"^",1:"") ; Return '^' to skip printing, "" to scroll on
;
BROAD() ; Checks if the 'Detailed Procedure Required' field on the Rad/Nuc Med
; Division file is 'yes', and the procedure type is 'Broad'.
; Variables: Y-the ien of the procedure in file 71
; RALIFN-ien of patient location in file 44 (set in RAORD1)
; Return: 0 if invalid procedure, 1 if valid procedure
Q $S($P($G(^RAMIS(71,Y,0)),"^",6)="B"&($P($G(^RA(79,+$$DIVSION^RAUTL6(DT,RALIFN),.1)),"^",7)="Y"):0,1:1)
RAPRI ;HISC/CAH,GJC AISC/DMK-Display Common Procedures ;3/12/98 11:26
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DISP ;Display list of common procedures - called from RAORD1
+1 WRITE !
DO EN1^RAUTL17
SET RAIMGTYI=Y
IF RAIMGTYI'>0
GOTO DISPQ
DISP1 IF '$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,0))
SET RACNT=0
GOTO DISPQ
+1 DO HOME^%ZIS
WRITE @IOF
+2 SET X="COMMON RADIOLOGY/NUCLEAR MEDICINE PROCEDURES ("_$PIECE($GET(^RA(79.2,RAIMGTYI,0)),U)_")"
WRITE !?80-$LENGTH(X)\2,X,!?80-$LENGTH(X)\2,$TRANSLATE($JUSTIFY("",$LENGTH(X))," ","-")
+3 SET II=0
FOR I=1:1:40
SET RAPRC(I)=""
+4 DO TOTAL
+5 FOR I=1:1:RASEQ
IF RAPRC(I)]""
WRITE !?1,I,") ",$PIECE(RAPRC(I),"^")
IF RAPRC(I+RASEQ)]""
WRITE ?44,(I+RASEQ),") ",$PIECE(RAPRC(I+RASEQ),"^")
DISPQ KILL I,II,RASEQ,DISYS,POP
+1 QUIT
LOOKUP ;Lookup procedure - called from RAORD1
+1 ;If user enters the sequential number on the common procedure list,
+2 ;the only screening done takes place when the procedure is stuffed
+3 ;in the input template. If user enters the name or CPT of a procedure
+4 ;at the prompt, additional screening takes place. Common procedures
+5 ;are not division-specific, so there is no way of stopping adpac's
+6 ;from using 'Broad' procedures on a common list.
+7 IF X?1.2N
IF +X=X
IF X'>RACNT
SET Y=$PIECE($GET(RAPRC(X)),"^",2)
IF '$$BROAD()
SET Y=-1
GOTO Q
+8 NEW DIC,Y
WRITE !
SET DIC(0)="EQMZ"
SET DIC="^RAMIS(71,"
+9 SET DIC("S")="N RAI,RA0 S RAI=$G(^(""I"")),RA0=$G(^(0)) I $S('RAI:1,DT'>RAI:1,1:0),$P(RA0,U,12)=RAIMGTYI,$S($P(RA0,U,6)=""P"":$O(^RAMIS(71,+Y,4,0)),1:1)"
+10 SET DIC("S")=DIC("S")_",$$BROAD^RAPRI()"
+11 DO ^DIC
KILL DIC("S")
IF X=""!(X="^")
SET Y=-1
Q SET (RAPRI,X)=+Y
SET RAPRI("X")=$PIECE($GET(^RAMIS(71,RAPRI,0)),"^")
+1 ;GJC@12/27/93 modified GJC@2-26-96
IF X>0
Begin DoDot:1
+2 IF $ORDER(^RAMIS(71,RAPRI,3,0))!($ORDER(^RAMIS(71,RAPRI,"EDU",0)))
DO EN2
+3 SET RAS3=RADFN
+4 DO ORDPRC1^RAUTL2
+5 QUIT
End DoDot:1
IF RAPRI'>0
QUIT
+6 IF RAPRI>0
QUIT
SET RAREASK=1
WRITE !!,*7,"Unable to process this request due to an invalid procedure.",!
IF $PIECE(RARX,",",(RAJ+1))=""
READ X:3
QUIT
+7 SET DIR(0)="Y"
SET DIR("A")="Continue processing remaining input"
DO ^DIR
KILL DIR
IF Y'=1
SET RAOUT=1
QUIT
HELP ; Called from ADDORD1^RAORD1
+1 IF $EXTRACT(RARX,1,2)="??"
Begin DoDot:1
+2 ; display screened entries from Rad/Nuc Med Procedure file
+3 NEW D,DIC,DZ,RADIC
SET D="B"
+4 SET RADIC("S")="N RA S RA(0)=$G(^(0)),RA(""I"")=$G(^RAMIS(71,+Y,""I""))"
+5 SET RADIC("S1")=" I $P(RA(0),U,12)=RAIMGTYI,('RA(""I"")!(DT<RA(""I"")))"
+6 SET DIC="^RAMIS(71,"
SET DIC(0)="Q"
SET DIC("S")=RADIC("S")_RADIC("S1")
SET DZ="??"
+7 SET DIC("W")="W "" "",?54,$$PRCCPT^RADD1()"
DO DQ^DICQ
+8 QUIT
End DoDot:1
+9 WRITE !!?2,"To select a commonly ordered procedure, enter a number from the display above."
+10 WRITE !!?2,"To select procedures other than those listed above, enter the procedure name,",!?2,"synonym, or CPT number.",!!?2,"You may enter a single procedure or multiple procedures separated by commas."
+11 WRITE !?2,"To see a list of all selectable procedures, enter '??'.",!
+12 SET DIR(0)="E"
DO ^DIR
KILL DIR
+13 QUIT
EN2 ;Rad/Nuc Med Procedure Message Display
+1 ; Quit if you've seen these messages before. Value altered in the
+2 ; following routines: ADDORD+1^RAORD1 & DISP+12^RAORDU1
+3 ;ATTENTION: This code must be parallel to code in PROGMSG^RAUTL5
+4 IF +$GET(RASTOP)
QUIT
SET RASTOP=1
+5 NEW RAXIT
SET RAXIT=""
IF $Y
WRITE @IOF
+6 IF $ORDER(^RAMIS(71,RAPRI,3,0))
Begin DoDot:1
+7 NEW I,RAX,X
SET I=0
+8 WRITE !!,*7,"NOTE: The following special requirements apply to this procedure: ",RAPRI("X"),!
+9 FOR
SET I=$ORDER(^RAMIS(71,RAPRI,3,I))
IF I'>0
QUIT
Begin DoDot:2
+10 SET RAX=+$GET(^RAMIS(71,RAPRI,3,I,0))
+11 IF $DATA(^RAMIS(71.4,+RAX,0))
Begin DoDot:3
+12 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAPRI()
IF RAXIT="^"
QUIT
WRITE @IOF
+13 SET X=$GET(^RAMIS(71.4,+RAX,0))
WRITE !,X
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
IF RAXIT="^"
QUIT
+16 QUIT
End DoDot:1
+17 IF $ORDER(^RAMIS(71,RAPRI,"EDU",0))
IF ($$UP^XLFSTR($PIECE($GET(^RAMIS(71,RAPRI,0)),"^",17))="Y")
Begin DoDot:1
+18 IF +$ORDER(^RAMIS(71,+RAPRI,3,0))>0
WRITE !!
+19 NEW DIW,DIWF,DIWL,DIWR,RAX,X
+20 KILL ^UTILITY($JOB,"W")
SET DIWF="W"
SET DIWL=1
SET DIWR=75
SET RAX=0
+21 FOR
SET RAX=$ORDER(^RAMIS(71,RAPRI,"EDU",RAX))
IF RAX'>0
QUIT
Begin DoDot:2
+22 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAPRI()
IF RAXIT="^"
QUIT
WRITE @IOF
+23 SET X=$GET(^RAMIS(71,RAPRI,"EDU",RAX,0))
DO ^DIWP
+24 QUIT
End DoDot:2
IF RAXIT="^"
QUIT
+25 IF RAXIT="^"
QUIT
+26 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAPRI()
IF RAXIT="^"
QUIT
WRITE @IOF
+27 IF RAXIT="^"
QUIT
DO ^DIWW
+28 QUIT
End DoDot:1
+29 IF RAXIT="^"
QUIT
+30 WRITE !
IF $GET(DR)="[RA QUICK EXAM ORDER]"!(($Y+5)>IOSL)
WRITE !,"Press RETURN to continue"
READ RAJUNK:DTIME
KILL RAJUNK
+31 QUIT
+32 ;
TOTAL NEW I,J,K,L
+1 SET (I,K,L,RACNT)=0
+2 FOR
SET I=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,I))
IF I>40!('I)
QUIT
SET RACNT=I
FOR
SET K=$ORDER(^(I,K))
IF 'K
QUIT
IF $DATA(^RAMIS(71.3,K,0))
SET RAPRC(I)=$EXTRACT($PIECE($GET(^RAMIS(71,+^(0),0)),"^"),1,32)_"^"_$PIECE(^RAMIS(71.3,K,0),"^")
+3 SET RASEQ=$SELECT(RACNT<40:(RACNT\2),1:20)
+4 IF RACNT#2
SET RASEQ=RASEQ+1
+5 QUIT
GET(DA) ;Get the IEN for the procedure. Used in input transform
+1 ;file 75.1 (Rad/Nuc Med Orders), field 125 (Modifiers).CEW
+2 QUIT +$PIECE($GET(^RAO(75.1,DA,0)),U,2)
EOS() ; End of screen message, 'Press return to continue'
+1 NEW X
+2 ; entered through Rad/Nuc Med
IF $DATA(RAPKG)
Begin DoDot:1
+3 READ !!?5,"Press return to continue ",X:DTIME
IF '$TEST
SET X="^"
+4 QUIT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 DO READ^ORUTL
IF '$TEST
SET X="^"
+7 QUIT
End DoDot:1
+8 ; Return '^' to skip printing, "" to scroll on
QUIT $SELECT($EXTRACT(X)="^":"^",1:"")
+9 ;
BROAD() ; Checks if the 'Detailed Procedure Required' field on the Rad/Nuc Med
+1 ; Division file is 'yes', and the procedure type is 'Broad'.
+2 ; Variables: Y-the ien of the procedure in file 71
+3 ; RALIFN-ien of patient location in file 44 (set in RAORD1)
+4 ; Return: 0 if invalid procedure, 1 if valid procedure
+5 QUIT $SELECT($PIECE($GET(^RAMIS(71,Y,0)),"^",6)="B"&($PIECE($GET(^RA(79,+$$DIVSION^RAUTL6(DT,RALIFN),.1)),"^",7)="Y"):0,1:1)
