- 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)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPRI 5274 printed Feb 19, 2025@00:05:02 Page 2
- 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)