- RAUTL19 ;HISC/GJC-Utility Routine ; Apr 28, 2020@14:47:46
- ;;5.0;Radiology/Nuclear Medicine;**1,31,169**;Mar 16, 1998;Build 2
- ;
- ;IA Type File Routine Tag
- ;------------------------------------------------
- ;1362 (C) ORB3 EN
- ;
- PRELIM(RAIMG) ; Called from '1^RAMAIN1'
- W !!?(IOM-$L(RAHDR)\2),RAHDR K %ZIS S %ZIS="MQ" W !
- D ^%ZIS Q:POP
- I $D(IO("Q")) D W ! Q
- . S ZTDESC="Rad/Nuc Med Exam Status Entry/Edit Report",ZTSAVE("RA*")=""
- . S ZTRTN="EN1^RAUTL19" D ^%ZTLOAD
- . W !?5,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
- . Q
- I IO'=IO(0) U IO
- D EN1 I IO'=IO(0) D HOME^%ZIS
- Q
- EN1 ; Check data consistency
- D EN1^RAUTL19C
- Q
- NOTNEED ;non-radiopharm used don't need .5n and .6n fields answered
- Q:RANODE(.5)'["Y"&(RANODE(.6)'["Y")
- W !!,RADASH,"Checking fields not needed by non-nucmed imaging",RADASH
- W !!?11,"Within : ",RAIMG,!?5,"The following need not be answered :"
- W !?5,"Exam Status '",$P(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '",!
- N RAIMG0,RAIMG1,RAIMG2
- S RAIMG1=.50,RAIMG2=.69,RAIMG0=RAIMG1
- F S RAIMG0=$O(RAPIECE(RAIMG0)) Q:RAIMG0>RAIMG2 Q:RAIMG0="" I RAPIECE(RAIMG0)="Y" W !,"'",$P($G(^DD(72,RAIMG0,.1)),U),"' is set to ",RAPIECE(RAIMG0)
- W !
- Q
- CKPRNTR ;ck that all img locations for that img type has a dosg tkt prntr
- N RAIMG72,RA791,RA791FL
- S RAIMG72=$P(RANODE(0),U,7),RA791=0,RA791FL=0
- F S RA791=$O(^RA(79.1,"BIMG",RAIMG72,RA791)) Q:'RA791 I $P(^RA(79.1,RA791,0),U,23)="" D PRNTASGN Q:RAOUT
- Q
- PRNTASGN ;
- W:'RA791FL !!,RADASH,"Checking Dosage Ticket Printer Assignment",RADASH
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W:'RA791FL !!?11,"Within : ",RAIMG,!?5,"Exam Status '",$P(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '"_$P($G(^DD(72,.611,.1)),U)_"'",!?5,"is set to 'Yes' but",!?5,"there's no Dosage Ticket Printer assigned to :"
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- S RA791FL=1
- W !?15,$P(^SC($P(^RA(79.1,RA791,0),U),0),U)
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- Q
- WRPAIR I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W:'RACHKERR !!,RADASH,"Checking fields that are inter-related",RADASH
- S RACHKERR=1 ;only write this once
- Q
- CKPAIR ; when field I is Y, then field J must also be Y at current/lower status
- D CKPAIR^RAUTL19C
- Q
- WRWAIT W:'RAWATERR !!,RADASH,"Checking ",$P(RANODE(0),U,1),"'s 'ASK' and 'REQUIRED' fields",RADASH,!?11,"within : ",RAIMG,!
- S RAWATERR=1 ;only write this once regardless of number of errors found
- Q
- CKWAIT ; CKWAIT is only done for WAITING FOR EXAM and assumes order seq = 1
- D CKWAIT^RAUTL19C
- Q
- ASKPRI(A,B,C) ; Check all prior statuses to ensure that the specific required
- ; data field is set to 'yes', and the field for data asked is set to
- ; 'yes'.
- ; 'A' is the I-Type (external) <-> 'B' is the current status order
- ; 'C' is fld that shd be prompted <-> 'E' is the order #
- ; 'F' is the ien of file 72. <-> 'RA' hold the entire data node
- ; 'RAFLD' value of the field <-> 'RAPCE' where data found on node
- N E,F,RA,RAFLD,RAPCE S E=0
- F S E=$O(^RA(72,"AA",A,E)) Q:E'>0!(E'<B) D Q:RAFLG
- . S F=+$O(^RA(72,"AA",A,E,0)) Q:'F
- . S RA(0)=$G(^RA(72,F,0))
- . I $$UP^XLFSTR($P(RA(0),"^",5))="Y" D ; if on Status Tracking
- .. S RAPCE=$E(C,3,$L(C)) ;pce is after 2nd byte, & is 1 or 2 bytes long
- .. S RA($E(C,1,2))=$G(^RA(72,F,$E(C,1,2))),RAFLD=$P(RA($E(C,1,2)),"^",RAPCE)
- .. S:$$UP^XLFSTR(RAFLD)="Y" RAFLG=1
- .. Q
- . Q
- Q RAFLG
- PROCTY(Y) ; Passes back the Procedure Type. 'Y' is the ien in the
- ; Rad/Nuc Med Procedure file '^RAMIS(71,'.
- Q $$UP^XLFSTR($P($G(^RAMIS(71,+Y,0)),"^",6))
- LK(X) ; Lock a patient record when updating orders
- ; 'X' input in a variable pointer format: 'record_#;data_file__root'
- ; Pass back 'Y': '0' if lock fails, '1' if successful
- ; 'Y' defined in LK^ORX2
- Q 1
- ULK(X) ; Unlock a patient record
- ; 'X' input in a variable pointer format: 'record_#;data_file__root'
- Q
- ACCVIO ; Lack of Imaging Location access for a user
- W !?5,$C(7),"You do not have access to any Imaging Locations."
- W !?5,"Contact your ADPAC."
- Q
- DEV(X) ; Lookup an entry in the Device (3.5) file.
- ; Called from the [RA LOCATION PARAMETERS] input template. File: 79.1
- ; Input: X=IEN of Device
- ; Output: Name of Device
- Q:'$L(X) ""
- I X?1N.NP Q $P($G(^%ZIS(1,X,0)),"^")
- Q ""
- OENO(X) ; OE/RR notifications, called from: RAORR1, RAORD1 & RAO7RO
- ; Input: 'X' -> ien of the Rad/Nuc Med Orders file (75.1)
- ; Notification: #51 - STAT IMAGING REQUEST & #52 - URGENT IMAGING REQUEST
- N I,RA751,RADFN,RADUZ,RALOC,RAMSG,RANOTY,RAORIFN
- S RA751=$G(^RAO(75.1,X,0)),RADFN=+$P(RA751,"^"),RANOTY=$P(RA751,"^",6)
- S RAORIFN=$P(RA751,"^",7) ;CPRS order IFN RA5P169
- S RANOTY=$S(RANOTY=1:51,RANOTY=2:52,1:"") Q:RANOTY=""
- S RALOC=$P(RA751,"^",20) Q:RALOC']"" ; no i-loc, no alert
- S I=0 F S I=$O(^RA(79.1,RALOC,"REC","B",I)) Q:I'>0 D
- . S RADUZ(I)=""
- . Q
- S:($D(RADUZ)\10)=0 RADUZ="" ; NOTE: if no rad/nuc med recipients, check
- ; oe/rr to see if they have any recipients for this particular alert
- S RAMSG="Imaging Request Urgency: "_$$XTERNAL^RAUTL5($P(RA751,"^",6),$P($G(^DD(75.1,6,0)),"^",2))
- D EN^ORB3(RANOTY,RADFN,RAORIFN,.RADUZ,RAMSG)
- Q
- VRADE ;VistaRad Category data entry
- I '$$IMAGE^RARIC1() W !!,"Current system is not running Vista Imaging -- nothing done.",! Q
- S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
- D ^DIC K DIC G:+Y'>0 VRADQ
- S RAOUT=0,RAIMGTYI=+Y,RAIMGTYJ=$P(Y,U,2)
- F D Q:RAOUT
- . K DINUM,DLAYGO,D0 W !
- . S DIC="^RA(72,",DIC(0)="QEAZ" ; don't allow LAYGO
- . S DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
- . S RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
- . S RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
- . S RADICW(3)=",!?35,""Order: "",?42,RA(3)"
- . S DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
- . D ^DIC K DIC,RADICW
- . I +Y'>0 S RAOUT=1 Q
- . S DA=+Y,DIE="^RA(72,",DR="9" D ^DIE
- . Q
- VRADQ K RAIMGTYI,RAIMGTYJ,RAOUT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL19 6063 printed Jan 18, 2025@03:41:18 Page 2
- RAUTL19 ;HISC/GJC-Utility Routine ; Apr 28, 2020@14:47:46
- +1 ;;5.0;Radiology/Nuclear Medicine;**1,31,169**;Mar 16, 1998;Build 2
- +2 ;
- +3 ;IA Type File Routine Tag
- +4 ;------------------------------------------------
- +5 ;1362 (C) ORB3 EN
- +6 ;
- PRELIM(RAIMG) ; Called from '1^RAMAIN1'
- +1 WRITE !!?(IOM-$LENGTH(RAHDR)\2),RAHDR
- KILL %ZIS
- SET %ZIS="MQ"
- WRITE !
- +2 DO ^%ZIS
- if POP
- QUIT
- +3 IF $DATA(IO("Q"))
- Begin DoDot:1
- +4 SET ZTDESC="Rad/Nuc Med Exam Status Entry/Edit Report"
- SET ZTSAVE("RA*")=""
- +5 SET ZTRTN="EN1^RAUTL19"
- DO ^%ZTLOAD
- +6 WRITE !?5,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled!")
- +7 QUIT
- End DoDot:1
- WRITE !
- QUIT
- +8 IF IO'=IO(0)
- USE IO
- +9 DO EN1
- IF IO'=IO(0)
- DO HOME^%ZIS
- +10 QUIT
- EN1 ; Check data consistency
- +1 DO EN1^RAUTL19C
- +2 QUIT
- NOTNEED ;non-radiopharm used don't need .5n and .6n fields answered
- +1 if RANODE(.5)'["Y"&(RANODE(.6)'["Y")
- QUIT
- +2 WRITE !!,RADASH,"Checking fields not needed by non-nucmed imaging",RADASH
- +3 WRITE !!?11,"Within : ",RAIMG,!?5,"The following need not be answered :"
- +4 WRITE !?5,"Exam Status '",$PIECE(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '",!
- +5 NEW RAIMG0,RAIMG1,RAIMG2
- +6 SET RAIMG1=.50
- SET RAIMG2=.69
- SET RAIMG0=RAIMG1
- +7 FOR
- SET RAIMG0=$ORDER(RAPIECE(RAIMG0))
- if RAIMG0>RAIMG2
- QUIT
- if RAIMG0=""
- QUIT
- IF RAPIECE(RAIMG0)="Y"
- WRITE !,"'",$PIECE($GET(^DD(72,RAIMG0,.1)),U),"' is set to ",RAPIECE(RAIMG0)
- +8 WRITE !
- +9 QUIT
- CKPRNTR ;ck that all img locations for that img type has a dosg tkt prntr
- +1 NEW RAIMG72,RA791,RA791FL
- +2 SET RAIMG72=$PIECE(RANODE(0),U,7)
- SET RA791=0
- SET RA791FL=0
- +3 FOR
- SET RA791=$ORDER(^RA(79.1,"BIMG",RAIMG72,RA791))
- if 'RA791
- QUIT
- IF $PIECE(^RA(79.1,RA791,0),U,23)=""
- DO PRNTASGN
- if RAOUT
- QUIT
- +4 QUIT
- PRNTASGN ;
- +1 if 'RA791FL
- WRITE !!,RADASH,"Checking Dosage Ticket Printer Assignment",RADASH
- +2 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- if RAOUT
- QUIT
- DO HEAD^RAUTL11
- +3 if 'RA791FL
- WRITE !!?11,"Within : ",RAIMG,!?5,"Exam Status '",$PIECE(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '"_$PIECE($GET(^DD(72,.611,.1)),U)_"'",!?5,"is set to 'Yes' but",!?5,"there's no Dosage Ticket Printer assigned to :"
- +4 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- if RAOUT
- QUIT
- DO HEAD^RAUTL11
- +5 SET RA791FL=1
- +6 WRITE !?15,$PIECE(^SC($PIECE(^RA(79.1,RA791,0),U),0),U)
- +7 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- if RAOUT
- QUIT
- DO HEAD^RAUTL11
- +8 QUIT
- WRPAIR IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- if RAOUT
- QUIT
- DO HEAD^RAUTL11
- +1 if 'RACHKERR
- WRITE !!,RADASH,"Checking fields that are inter-related",RADASH
- +2 ;only write this once
- SET RACHKERR=1
- +3 QUIT
- CKPAIR ; when field I is Y, then field J must also be Y at current/lower status
- +1 DO CKPAIR^RAUTL19C
- +2 QUIT
- WRWAIT if 'RAWATERR
- WRITE !!,RADASH,"Checking ",$PIECE(RANODE(0),U,1),"'s 'ASK' and 'REQUIRED' fields",RADASH,!?11,"within : ",RAIMG,!
- +1 ;only write this once regardless of number of errors found
- SET RAWATERR=1
- +2 QUIT
- CKWAIT ; CKWAIT is only done for WAITING FOR EXAM and assumes order seq = 1
- +1 DO CKWAIT^RAUTL19C
- +2 QUIT
- ASKPRI(A,B,C) ; Check all prior statuses to ensure that the specific required
- +1 ; data field is set to 'yes', and the field for data asked is set to
- +2 ; 'yes'.
- +3 ; 'A' is the I-Type (external) <-> 'B' is the current status order
- +4 ; 'C' is fld that shd be prompted <-> 'E' is the order #
- +5 ; 'F' is the ien of file 72. <-> 'RA' hold the entire data node
- +6 ; 'RAFLD' value of the field <-> 'RAPCE' where data found on node
- +7 NEW E,F,RA,RAFLD,RAPCE
- SET E=0
- +8 FOR
- SET E=$ORDER(^RA(72,"AA",A,E))
- if E'>0!(E'<B)
- QUIT
- Begin DoDot:1
- +9 SET F=+$ORDER(^RA(72,"AA",A,E,0))
- if 'F
- QUIT
- +10 SET RA(0)=$GET(^RA(72,F,0))
- +11 ; if on Status Tracking
- IF $$UP^XLFSTR($PIECE(RA(0),"^",5))="Y"
- Begin DoDot:2
- +12 ;pce is after 2nd byte, & is 1 or 2 bytes long
- SET RAPCE=$EXTRACT(C,3,$LENGTH(C))
- +13 SET RA($EXTRACT(C,1,2))=$GET(^RA(72,F,$EXTRACT(C,1,2)))
- SET RAFLD=$PIECE(RA($EXTRACT(C,1,2)),"^",RAPCE)
- +14 if $$UP^XLFSTR(RAFLD)="Y"
- SET RAFLG=1
- +15 QUIT
- End DoDot:2
- +16 QUIT
- End DoDot:1
- if RAFLG
- QUIT
- +17 QUIT RAFLG
- PROCTY(Y) ; Passes back the Procedure Type. 'Y' is the ien in the
- +1 ; Rad/Nuc Med Procedure file '^RAMIS(71,'.
- +2 QUIT $$UP^XLFSTR($PIECE($GET(^RAMIS(71,+Y,0)),"^",6))
- LK(X) ; Lock a patient record when updating orders
- +1 ; 'X' input in a variable pointer format: 'record_#;data_file__root'
- +2 ; Pass back 'Y': '0' if lock fails, '1' if successful
- +3 ; 'Y' defined in LK^ORX2
- +4 QUIT 1
- ULK(X) ; Unlock a patient record
- +1 ; 'X' input in a variable pointer format: 'record_#;data_file__root'
- +2 QUIT
- ACCVIO ; Lack of Imaging Location access for a user
- +1 WRITE !?5,$CHAR(7),"You do not have access to any Imaging Locations."
- +2 WRITE !?5,"Contact your ADPAC."
- +3 QUIT
- DEV(X) ; Lookup an entry in the Device (3.5) file.
- +1 ; Called from the [RA LOCATION PARAMETERS] input template. File: 79.1
- +2 ; Input: X=IEN of Device
- +3 ; Output: Name of Device
- +4 if '$LENGTH(X)
- QUIT ""
- +5 IF X?1N.NP
- QUIT $PIECE($GET(^%ZIS(1,X,0)),"^")
- +6 QUIT ""
- OENO(X) ; OE/RR notifications, called from: RAORR1, RAORD1 & RAO7RO
- +1 ; Input: 'X' -> ien of the Rad/Nuc Med Orders file (75.1)
- +2 ; Notification: #51 - STAT IMAGING REQUEST & #52 - URGENT IMAGING REQUEST
- +3 NEW I,RA751,RADFN,RADUZ,RALOC,RAMSG,RANOTY,RAORIFN
- +4 SET RA751=$GET(^RAO(75.1,X,0))
- SET RADFN=+$PIECE(RA751,"^")
- SET RANOTY=$PIECE(RA751,"^",6)
- +5 ;CPRS order IFN RA5P169
- SET RAORIFN=$PIECE(RA751,"^",7)
- +6 SET RANOTY=$SELECT(RANOTY=1:51,RANOTY=2:52,1:"")
- if RANOTY=""
- QUIT
- +7 ; no i-loc, no alert
- SET RALOC=$PIECE(RA751,"^",20)
- if RALOC']""
- QUIT
- +8 SET I=0
- FOR
- SET I=$ORDER(^RA(79.1,RALOC,"REC","B",I))
- if I'>0
- QUIT
- Begin DoDot:1
- +9 SET RADUZ(I)=""
- +10 QUIT
- End DoDot:1
- +11 ; NOTE: if no rad/nuc med recipients, check
- if ($DATA(RADUZ)\10)=0
- SET RADUZ=""
- +12 ; oe/rr to see if they have any recipients for this particular alert
- +13 SET RAMSG="Imaging Request Urgency: "_$$XTERNAL^RAUTL5($PIECE(RA751,"^",6),$PIECE($GET(^DD(75.1,6,0)),"^",2))
- +14 DO EN^ORB3(RANOTY,RADFN,RAORIFN,.RADUZ,RAMSG)
- +15 QUIT
- VRADE ;VistaRad Category data entry
- +1 IF '$$IMAGE^RARIC1()
- WRITE !!,"Current system is not running Vista Imaging -- nothing done.",!
- QUIT
- +2 SET DIC="^RA(79.2,"
- SET DIC(0)="QEAMNZ"
- SET DIC("A")="Select an Imaging Type: "
- +3 DO ^DIC
- KILL DIC
- if +Y'>0
- GOTO VRADQ
- +4 SET RAOUT=0
- SET RAIMGTYI=+Y
- SET RAIMGTYJ=$PIECE(Y,U,2)
- +5 FOR
- Begin DoDot:1
- +6 KILL DINUM,DLAYGO,D0
- WRITE !
- +7 ; don't allow LAYGO
- SET DIC="^RA(72,"
- SET DIC(0)="QEAZ"
- +8 SET DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
- +9 SET RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
- +10 SET RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
- +11 SET RADICW(3)=",!?35,""Order: "",?42,RA(3)"
- +12 SET DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
- +13 DO ^DIC
- KILL DIC,RADICW
- +14 IF +Y'>0
- SET RAOUT=1
- QUIT
- +15 SET DA=+Y
- SET DIE="^RA(72,"
- SET DR="9"
- DO ^DIE
- +16 QUIT
- End DoDot:1
- if RAOUT
- QUIT
- VRADQ KILL RAIMGTYI,RAIMGTYJ,RAOUT
- +1 QUIT