RAORD ;HISC/CAH,FPT,GJC,AISC/RMO - Rad/NM Order Entry Main Menu ; Dec 11, 2023@09:59:17
;;5.0;Radiology/Nuclear Medicine;**133,168,174,209**;Mar 16, 1998;Build 3
;
;NAME TAG IA # USAGE CUSTODIAN
;----------------------------------------------------------
;%DTC HELP 10000 Supported VA FILEMAN
;
2 ;;Schedule a Request
N RAPTLOCK,RAMIN S RAMIN=-30
;//P174 ask to schedule or reschedule //
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("A")="Schedule or Re-schedule request(s)",DIR("B")="Schedule"
S DIR(0)="S^1:Schedule;2:Re-Schedule"
S DIR("?",1)="Enter '1' to initially schedule request(s), else '2'"
S DIR("?")="to reschedule currently scheduled request(s)."
D ^DIR Q:$D(DIRUT)#2
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
N RAFLGA MERGE RAFLGA=Y
;RAFLGA: internal value ('1' or '2')
;RAFLGA(0): external value ('Schedule' or 'Re-Schedule')
;
21 ; Patient lookup
S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q2:Y<0
I $$ORVR^RAORDU()'<3 D G:'RAPTLOCK 21
. S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
. Q
S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")
;// P174 begin //
N RAX S RAX=$$RESCH(RAFLGA)
S (RAOFNS,RAOPTN)=$P(RAX,U) ;"Schedule" or "Re-Schedule"
;RAOVSTS = "3;5" for the schedule a request option &
;"8;" for reschedule a request option
S RAOVSTS=$P(RAX,U,2) ;"3;5" schedule -or- "8;" reschedule
;// P174 end //
;
W ! D ^RAORDS G Q2:'$D(RAORDS)
;// P174
K RAMAXDD,DIR,DIROUT,DIRUT,DTOUT,DUOUT
;find the largest DATE DESIRED from the order(s) selected by the user.
;use these values to beef up the help text when asking for the SCHEDULED DATE
S RAMAXDD=$$MAXDD(.RAORDS) ;by ref returns internal FM date
S RAMAXDD(0)=$$FMADD^XLFDT(RAMAXDD,210,0,0,0) ;get upper limit
W ! S DIR(0)="DA^"_$$DT^XLFDT_":"_RAMAXDD(0)_":ETX"
S DIR("A")="Enter the SCHEDULED DATE (TIME optional): "
S DIR("?",1)="The 'SCHEDULED DATE (TIME optional)' entered cannot"
S DIR("?")="be prior to TODAY and cannot exceed "_$$FMTE^XLFDT(RAMAXDD(0),"1P")_"."
S DIR("??")="^D HELP^%DTC"
D ^DIR Q:$D(DIRUT)#2
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S RAOSCH=Y,RAOLP=0
;S %DT("A")="Schedule Request Date/Time: ",%DT="AEFXT"
;W ! D ^%DT K %DT G Q2:Y<0 S RAOSCH=Y,RAOLP=0
F S RAOLP=+$O(RAORDS(RAOLP)) Q:'RAOLP!('+$G(RAORDS(RAOLP))) D
. N RAOIFN S RAOIFN=$G(RAORDS(RAOLP)) ;P174
. N RADIF,RAOK S RAOK=1 ;p209
. S RAOIFN(0)=$G(^RAO(75.1,RAOIFN,0)),RAOIFN(21)=$P(RAOIFN(0),U,21)
. ;1st param: RAOIFN(21) = date desired
. ;2nd param: RAOSCH scheduled date
. ;3rd param: 2nd can't exceed 1st by more than these # of days
. S RADIF=$$FMDIFF^XLFDT(RAOSCH,RAOIFN(21),1) ;p209/KLM get difference btwn DD and SD
. I $$OUTXDAYS(RAOIFN(21),RAOSCH,210)=1 D S RAOK=0
.. W !?3,"Procedure: "_$E($$GET1^DIQ(75.1,RAOIFN,2),1,20)_" not scheduled: date is out of range."
.. Q
. I RAOK=1,RADIF<RAMIN D ;p209/KLM - lower bound warning (30days)
.. K DIR
.. W !?3,"Schedule date for "_$E($$GET1^DIQ(75.1,RAOIFN,2),1,20)_" is "_$P(RADIF,"-",2)_" days before the date desired!"
.. S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to continue" D ^DIR
.. I $D(DIRUT) S RAOK=0
.. S RAOK=Y
.. Q
. I RAOK=1 S RAOSTS=8 D ^RAORDU
. Q
D Q2 G 21
Q2 ; Unlock if appropriate, kill vars
I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D
. D ULK^RAUTL19(RADFN_";DPT(")
K %DT,C,D,D0,DA,I,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS,RAOSCH
K RAOPTN,RAOSTS,RAOVSTS,X,Y,RAMAXDD
K RAPARENT
K A1,D1,DDER,DDH,DI,DIPGM,POP,^TMP($J,"PRO-ORD")
Q
;
3 ;;Cancel a Request
N RAPTLOCK,RAXIT S RAXIT=0,RAPKG=""
31 ; Patient lookup
S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q3:Y<0
I $$ORVR^RAORDU()'<3 D G:'RAPTLOCK 31
. S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
. Q
S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")
S (RAOFNS,RAOPTN)="Cancel"
D CHKUSR^RAUTL2 S RAOVSTS=$S(RAMSG:"3;5;8",1:"5")
W ! D ^RAORDS G Q3:'$D(RAORDS)
D REASON G Q3:RAXIT!(+$G(OREND))
ENCAN ;OE/RR Entry Point for the CANCEL ACTION Option
K ORSTRT,ORSTOP,ORTO,ORTX,ORIT,ORCOST,ORPURG
I $D(RAPKG) W !?3,"...will now 'CANCEL' selected request(s)..."
S RAOLP=0
F S RAOLP=+$O(RAORDS(RAOLP)) Q:'RAOLP!('+$G(RAORDS(RAOLP))) D
. S RAOIFN=$G(RAORDS(RAOLP)),RAOSTS=1 D ^RAORDU
. I $D(RAPKG),$D(^RAO(75.1,RAOIFN,0)),$D(^RAMIS(71,+$P(^(0),"^",2),0)) W !?10,"...",$P(^(0),"^")," cancelled..."
. ; Print Cancelled Requests if appropriate
. K RA751,RA791 S RA751=$G(^RAO(75.1,RAOIFN,0))
. S RA791=$G(^RA(79.1,+$P(RA751,"^",20),0))
. I $P(RA791,"^",24)]""!(+$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),"^",24)) D
.. K RACRHD,RAION,RAPGE,RAX S RAPGE=0,(RACRHD,RAX)=""
.. ; RAOIFN already defined, RADFN may/maynot be defined!
.. I '$D(RADFN) N RADFN S RADFN=+$P(RA751,"^")
.. S RAION=$S($P(RA791,"^",24)]"":$P(RA791,"^",24),1:+$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),"^",24))
.. S RAION=$$GET1^DIQ(3.5,RAION_",",.01)
.. D PCR ; Print Cancelled Request subroutine
.. K RACRHD,RAION,RAPGE,RAX
.. Q
. K RA751,RA791
. Q
Q3 ; unlock if appropriate, kill variables
I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D
. D ULK^RAUTL19(RADFN_";DPT(")
K %,%DT,C,D,D0,DA,POP,RADFN,RADIV,RAMSG,RANME,RAOFNS,RAOIFN,RAOLP
K RAOPTN,RAORDS,RAOSTS,RAOVSTS I $D(RAPKG) K OREND,RAPKG
I '$D(N)!($D(RAOREA)<10) K RAPARENT,X,Y
I '$D(N)!($D(RAOREA)<10) K RAOREA G Q35
I $D(RAOREA)>1,$G(N) K RAOREA(N),N I $D(RAOREA)<10 K RAOREA
K RAPARENT,X,Y
Q35 K DIPGM,I
Q
CHECK ; Check on the status of the order
S OREND=$S(ORSTS=5:0,ORSTS=11:0,1:1) W:OREND !!,"Only orders in a Pending or Unreleased status can be cancelled.",$C(7)
Q
REASON ; Select a Cancel Reason
S DIC("A")="Select CANCEL REASON: ",DIC("S")="I $P(^(0),U,2)=1!($P(^(0),U,2)=9)",DIC="^RA(75.2,",DIC(0)="AEMQ"
W ! D ^DIC K DIC
I +Y<0,(X["^") S RAXIT=1 Q
I +Y<0 W !!?3,"A Cancel Reason is required to proceed." G REASON
S OREND=0,RAOREA($S($D(ORPK):ORPK,$D(ORIFN):ORIFN,1:1))=+Y
Q
4 ;;Hold a Request
N RAPTLOCK
40 ; Patient lookup
S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q4:Y<0
I $$ORVR^RAORDU()'<3 D G:'RAPTLOCK 40
. S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
. Q
S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")
S (RAOFNS,RAOPTN)="Hold",RAOVSTS="5;8"
W ! D ^RAORDS G Q4:'$D(RAORDS)
41 ; Select a Hold Reason
S DIC("A")="Select HOLD REASON: ",DIC("S")="I $P(^(0),U,2)=3!($P(^(0),U,2)=9)",DIC="^RA(75.2,",DIC(0)="AEMQ" W ! D ^DIC K DIC
I +Y<0,(X["^") D Q4 Q
I +Y<0 W !!?3,"A Hold Reason is required to proceed." G 41
S RAOREA=+Y
W !?3,"...will now 'HOLD' selected request(s)..." S RAOLP=0
F S RAOLP=+$O(RAORDS(RAOLP)) Q:'RAOLP!('+$G(RAORDS(RAOLP))) D
. S RAOIFN=$G(RAORDS(RAOLP)),RAOSTS=3 D ^RAORDU
. I $D(^RAO(75.1,RAOIFN,0)),$D(^RAMIS(71,+$P(^(0),"^",2),0)) W !?10,"...",$P(^(0),"^")," held..."
. Q
D Q4 G 40
Q4 ; unlock if appropriate, kill variables
I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D
. D ULK^RAUTL19(RADFN_";DPT(")
K %DT,C,D,D0,DA,I,POP,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS
K RAOPTN,RAOREA,RAOSTS,RAOVSTS,X,Y
K D1,DDER,DI,DIPGM,DISYS,DUOUT,RAPARENT,^TMP($J,"PRO-ORD"),^("XQALSET")
Q
;
6 ;;Udate a HOLD REASON /RA*5*133
N RAPTLOCK
60 ; Patient lookup
S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G 64:Y<0
S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown")
S (RAOFNS,RAOPTN)="Update hold reason",RAOVSTS="3"
W ! D ^RAORDS G 64:'$D(RAORDS)
61 ; Select a Hold Reason
;p168 - change lookup to catch types hold and general (3&9)
S DIC("A")="Select HOLD REASON: ",DIC("S")="I $P(^(0),U,2)=3!($P(^(0),U,2)=9)",DIC="^RA(75.2,",DIC(0)="AEMQ" W ! D ^DIC K DIC
I +Y<0,(X["^") D 64 Q
I +Y<0 W !!?3,"A Hold Reason is required to proceed." G 61
S RAOREA=+Y
W !?3,"...will now update the hold reason for the selected request(s)..." S RAOLP=0
F S RAOLP=+$O(RAORDS(RAOLP)) Q:'RAOLP!('+$G(RAORDS(RAOLP))) D
. S RAOIFN=$G(RAORDS(RAOLP)),RAOSTS=3 D ^RAORDU
. I $D(^RAO(75.1,RAOIFN,0)),$D(^RAMIS(71,+$P(^(0),"^",2),0)) W !?10,"...",$P(^(0),"^")," updated..."
. Q
D 64 G 60
64 ; unlock if appropriate, kill variables
K %DT,C,D,D0,DA,I,POP,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS
K RAOPTN,RAOREA,RAOSTS,RAOVSTS,X,Y
K D1,DDER,DI,DIPGM,DISYS,DUOUT,RAPARENT,^TMP($J,"PRO-ORD"),^("XQALSET")
Q
;
9 ;;Print Selected Requests by Patient
K ^TMP($J,"RA PRINT HS BY PAT")
S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC G Q9:Y<0 S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown"),RAOFNS="Print",RAOVSTS="1;2;3;5;6;8" W ! D ^RAORDS G Q9:'$D(RAORDS)
S RAOIFNS="" F RAOLP=1:1 Q:'$D(RAORDS(RAOLP)) S RAOIFNS=RAOIFNS_+RAORDS(RAOLP)_";"
W ! K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("B")="No"
S DIR("?")="Answer 'Y'es to print the report, 'N'o to quit."
S DIR("A")="Do you wish to generate a Health Summary Report"
D ^DIR G:$D(DIRUT) Q9 S RAGMTS=+Y
S ZTRTN="START9^RAORD",ZTSAVE("RADFN")="",ZTSAVE("RAOIFNS")=""
S ZTSAVE("RAGMTS")="" S:$D(RAOPT) ZTSAVE("RAOPT(")=""
W ! D ZIS^RAUTL G Q9:RAPOP
;
START9 ; Start printing requests
U IO S RAX="" N RA751
F RAOLP=1:1 S RAOIFN=$P(RAOIFNS,";",RAOLP) Q:'RAOIFN!(RAX["^") D
. S RAPGE=0 D ^RAORD5 Q:RAX["^"
. D CRCHK^RAORD6 Q:RAX["^"
. Q:'RAGMTS ; quit if 'No' to 'generate a Health Summary Report'.
. S RA751(0)=$G(^RAO(75.1,RAOIFN,0)),RA751(2)=$P(RA751(0),"^",2)
. S GMTSTYP=$P($G(^RAMIS(71,+RA751(2),0)),"^",13)
. I GMTSTYP>0,('$D(^TMP($J,"RA PRINT HS BY PAT",GMTSTYP,RADFN))) D
.. W:$Y>0 @IOF D ENX^GMTSDVR(RADFN,GMTSTYP)
.. S ^TMP($J,"RA PRINT HS BY PAT",GMTSTYP,RADFN)=""
.. Q
. Q
Q9 K %DT,C,D,D0,DA,DFN,GMTSTYP,I,POP,RACNI,RADFN,RADIV,RADTI,RANME,RAOFNS
K RAOIFN,RAOIFNS,RAOLP,RAORDS,RAOSTS,RAOVSTS,RAPARENT,RAPGE,RAPOP,RAX
K RAGMTS,VAI,VAIN,X,Y,Z,^TMP($J,"RA PRINT HS BY PAT")
K RAMES,ZTDESC,ZTRTN,ZTSAVE
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
K DIPGM,DISYS,DIW,DIWT,DN,RA6,RA7,^TMP($J,"PRO-ORD")
W ! D CLOSE^RAUTL
Q
KILL ; kill variables - called from RAORD1
K %,%DT,D,D0,D1,DA,DFN,DIC,DIK,DIROUT,DIRUT,DIV,DR,DTOUT,DUOUT,DWPK,J,OREND,RABLNK,RACNT,RACT,RADIV,RAEXMUL,RAFIN,RAFIN1,RAI,RAILOC,RAIMGTYI,RAIP,RAJ,RAL0,RALOC,RALIFN,RALOCFLG
K RAMOD,RAMT,RANUM,RAOIFN,RAORD0,RAOUT,RAPIFN,RAPRC,RAPRI,RAPREG,RAPREOP1,RAREASK,RAREQDT,RAREQPRT,RARU,RARX,RASEQ,RAS3,RASEX,RASKPREG,RASTOP,RASX,RAWHEN,RAX,VAERR,VA200,VAI,VAIP,X,Y
K RAACI
I '$D(RAPKG),$G(XQORS)>1,$G(^TMP("XQORS",$J,XQORS-1,"ITM"))'=$G(^("TOT")) Q ;don't kill clin hist if order entry quick orders not all proccessed
K ^TMP($J,"RAWP")
Q
PCR ; Print Cancelled Requests. Called from the 'Cancel A Request' option.
N I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
S ZTDESC="Rad/Nuc Med Cancelled Request Print",ZTDTH=$H,ZTIO=RAION
S ZTRTN="^RAORD5"
F I="RACRHD","RADFN","RAOIFN","RAPGE","RAX" S ZTSAVE(I)=""
D ^%ZTLOAD W:$D(ZTSK) !!?3,$C(7),"Task "_ZTSK_": cancellation queued to print on device ",RAION,!
D HOME^%ZIS
Q
;
MAXDD(ARY) ;for the RIS orders (#75.1) selected by the user
;determine the DATE DESIRED (DD) farthest into the future.
;R = the DATE DESIRED farthest into the future
;X = 0 node (75.1) | X21 = RIS order DD
;Y = 'n' sequntial | ARY(Y) = record IEN (75.1)
N R,X,Y S (R,Y)=0 F S Y=$O(ARY(Y)) Q:Y'>0 D
.S X=$G(^RAO(75.1,ARY(Y),0)),X21=$P(X,U,21)
.S:X21>R R=X21
.Q
Q R ;FM internal
;
RESCH(Y) ;P174 - pass back subject and request statuses depending
;on the action: 'schedule request(s)' or 're-schedule request(s)'
;Input: 'Y': '1' for schedule, '2' for reschedule
;
N X S X="Schedule^"
Q $S(Y=2:"Re-"_X_"8;",1:X_"3;5")
;
OUTXDAYS(RAPD,RAQD,RAMAX) ;P174 - compare two dates. Are they
; within the max # of days allowed?
;
; Input: RAMAX = The number of days one date must be within
; another. For example: RAMAX = 210
; RAPD = Primary Date
; For Example: 'DATE DESIRED (Not guaranteed)'
; RAQD = Questionable Date
; For Example: 'SCHEDULED DATE (TIME optional)'
; (RAOSCH is the variable for this fld)
;
;Return: one (1) if the difference between RAQD and RAPD is more than
; the max # of days (RAMAX)
; zero (0) if RAQD is less than or equal to the RAPD by RAMAX
;
Q $S(($$FMDIFF^XLFDT(RAQD,RAPD,1)>RAMAX):1,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORD 12373 printed Sep 23, 2025@20:14:07 Page 2
RAORD ;HISC/CAH,FPT,GJC,AISC/RMO - Rad/NM Order Entry Main Menu ; Dec 11, 2023@09:59:17
+1 ;;5.0;Radiology/Nuclear Medicine;**133,168,174,209**;Mar 16, 1998;Build 3
+2 ;
+3 ;NAME TAG IA # USAGE CUSTODIAN
+4 ;----------------------------------------------------------
+5 ;%DTC HELP 10000 Supported VA FILEMAN
+6 ;
2 ;;Schedule a Request
+1 NEW RAPTLOCK,RAMIN
SET RAMIN=-30
+2 ;//P174 ask to schedule or reschedule //
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR("A")="Schedule or Re-schedule request(s)"
SET DIR("B")="Schedule"
+5 SET DIR(0)="S^1:Schedule;2:Re-Schedule"
+6 SET DIR("?",1)="Enter '1' to initially schedule request(s), else '2'"
+7 SET DIR("?")="to reschedule currently scheduled request(s)."
+8 DO ^DIR
if $DATA(DIRUT)#2
QUIT
+9 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+10 NEW RAFLGA
MERGE RAFLGA=Y
+11 ;RAFLGA: internal value ('1' or '2')
+12 ;RAFLGA(0): external value ('Schedule' or 'Re-Schedule')
+13 ;
21 ; Patient lookup
+1 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO Q2
+2 IF $$ORVR^RAORDU()'<3
Begin DoDot:1
+3 SET RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
+4 QUIT
End DoDot:1
if 'RAPTLOCK
GOTO 21
+5 SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
+6 ;// P174 begin //
+7 NEW RAX
SET RAX=$$RESCH(RAFLGA)
+8 ;"Schedule" or "Re-Schedule"
SET (RAOFNS,RAOPTN)=$PIECE(RAX,U)
+9 ;RAOVSTS = "3;5" for the schedule a request option &
+10 ;"8;" for reschedule a request option
+11 ;"3;5" schedule -or- "8;" reschedule
SET RAOVSTS=$PIECE(RAX,U,2)
+12 ;// P174 end //
+13 ;
+14 WRITE !
DO ^RAORDS
if '$DATA(RAORDS)
GOTO Q2
+15 ;// P174
+16 KILL RAMAXDD,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+17 ;find the largest DATE DESIRED from the order(s) selected by the user.
+18 ;use these values to beef up the help text when asking for the SCHEDULED DATE
+19 ;by ref returns internal FM date
SET RAMAXDD=$$MAXDD(.RAORDS)
+20 ;get upper limit
SET RAMAXDD(0)=$$FMADD^XLFDT(RAMAXDD,210,0,0,0)
+21 WRITE !
SET DIR(0)="DA^"_$$DT^XLFDT_":"_RAMAXDD(0)_":ETX"
+22 SET DIR("A")="Enter the SCHEDULED DATE (TIME optional): "
+23 SET DIR("?",1)="The 'SCHEDULED DATE (TIME optional)' entered cannot"
+24 SET DIR("?")="be prior to TODAY and cannot exceed "_$$FMTE^XLFDT(RAMAXDD(0),"1P")_"."
+25 SET DIR("??")="^D HELP^%DTC"
+26 DO ^DIR
if $DATA(DIRUT)#2
QUIT
+27 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+28 SET RAOSCH=Y
SET RAOLP=0
+29 ;S %DT("A")="Schedule Request Date/Time: ",%DT="AEFXT"
+30 ;W ! D ^%DT K %DT G Q2:Y<0 S RAOSCH=Y,RAOLP=0
+31 FOR
SET RAOLP=+$ORDER(RAORDS(RAOLP))
if 'RAOLP!('+$GET(RAORDS(RAOLP)))
QUIT
Begin DoDot:1
+32 ;P174
NEW RAOIFN
SET RAOIFN=$GET(RAORDS(RAOLP))
+33 ;p209
NEW RADIF,RAOK
SET RAOK=1
+34 SET RAOIFN(0)=$GET(^RAO(75.1,RAOIFN,0))
SET RAOIFN(21)=$PIECE(RAOIFN(0),U,21)
+35 ;1st param: RAOIFN(21) = date desired
+36 ;2nd param: RAOSCH scheduled date
+37 ;3rd param: 2nd can't exceed 1st by more than these # of days
+38 ;p209/KLM get difference btwn DD and SD
SET RADIF=$$FMDIFF^XLFDT(RAOSCH,RAOIFN(21),1)
+39 IF $$OUTXDAYS(RAOIFN(21),RAOSCH,210)=1
Begin DoDot:2
+40 WRITE !?3,"Procedure: "_$EXTRACT($$GET1^DIQ(75.1,RAOIFN,2),1,20)_" not scheduled: date is out of range."
+41 QUIT
End DoDot:2
SET RAOK=0
+42 ;p209/KLM - lower bound warning (30days)
IF RAOK=1
IF RADIF<RAMIN
Begin DoDot:2
+43 KILL DIR
+44 WRITE !?3,"Schedule date for "_$EXTRACT($$GET1^DIQ(75.1,RAOIFN,2),1,20)_" is "_$PIECE(RADIF,"-",2)_" days before the date desired!"
+45 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you want to continue"
DO ^DIR
+46 IF $DATA(DIRUT)
SET RAOK=0
+47 SET RAOK=Y
+48 QUIT
End DoDot:2
+49 IF RAOK=1
SET RAOSTS=8
DO ^RAORDU
+50 QUIT
End DoDot:1
+51 DO Q2
GOTO 21
Q2 ; Unlock if appropriate, kill vars
+1 IF $$ORVR^RAORDU()'<3
IF (+$GET(RAPTLOCK))
IF (+$GET(RADFN))
Begin DoDot:1
+2 DO ULK^RAUTL19(RADFN_";DPT(")
End DoDot:1
+3 KILL %DT,C,D,D0,DA,I,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS,RAOSCH
+4 KILL RAOPTN,RAOSTS,RAOVSTS,X,Y,RAMAXDD
+5 KILL RAPARENT
+6 KILL A1,D1,DDER,DDH,DI,DIPGM,POP,^TMP($JOB,"PRO-ORD")
+7 QUIT
+8 ;
3 ;;Cancel a Request
+1 NEW RAPTLOCK,RAXIT
SET RAXIT=0
SET RAPKG=""
31 ; Patient lookup
+1 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO Q3
+2 IF $$ORVR^RAORDU()'<3
Begin DoDot:1
+3 SET RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
+4 QUIT
End DoDot:1
if 'RAPTLOCK
GOTO 31
+5 SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
+6 SET (RAOFNS,RAOPTN)="Cancel"
+7 DO CHKUSR^RAUTL2
SET RAOVSTS=$SELECT(RAMSG:"3;5;8",1:"5")
+8 WRITE !
DO ^RAORDS
if '$DATA(RAORDS)
GOTO Q3
+9 DO REASON
if RAXIT!(+$GET(OREND))
GOTO Q3
ENCAN ;OE/RR Entry Point for the CANCEL ACTION Option
+1 KILL ORSTRT,ORSTOP,ORTO,ORTX,ORIT,ORCOST,ORPURG
+2 IF $DATA(RAPKG)
WRITE !?3,"...will now 'CANCEL' selected request(s)..."
+3 SET RAOLP=0
+4 FOR
SET RAOLP=+$ORDER(RAORDS(RAOLP))
if 'RAOLP!('+$GET(RAORDS(RAOLP)))
QUIT
Begin DoDot:1
+5 SET RAOIFN=$GET(RAORDS(RAOLP))
SET RAOSTS=1
DO ^RAORDU
+6 IF $DATA(RAPKG)
IF $DATA(^RAO(75.1,RAOIFN,0))
IF $DATA(^RAMIS(71,+$PIECE(^(0),"^",2),0))
WRITE !?10,"...",$PIECE(^(0),"^")," cancelled..."
+7 ; Print Cancelled Requests if appropriate
+8 KILL RA751,RA791
SET RA751=$GET(^RAO(75.1,RAOIFN,0))
+9 SET RA791=$GET(^RA(79.1,+$PIECE(RA751,"^",20),0))
+10 IF $PIECE(RA791,"^",24)]""!(+$PIECE($GET(^RA(79.1,+$ORDER(^RA(79.1,0)),0)),"^",24))
Begin DoDot:2
+11 KILL RACRHD,RAION,RAPGE,RAX
SET RAPGE=0
SET (RACRHD,RAX)=""
+12 ; RAOIFN already defined, RADFN may/maynot be defined!
+13 IF '$DATA(RADFN)
NEW RADFN
SET RADFN=+$PIECE(RA751,"^")
+14 SET RAION=$SELECT($PIECE(RA791,"^",24)]"":$PIECE(RA791,"^",24),1:+$PIECE($GET(^RA(79.1,+$ORDER(^RA(79.1,0)),0)),"^",24))
+15 SET RAION=$$GET1^DIQ(3.5,RAION_",",.01)
+16 ; Print Cancelled Request subroutine
DO PCR
+17 KILL RACRHD,RAION,RAPGE,RAX
+18 QUIT
End DoDot:2
+19 KILL RA751,RA791
+20 QUIT
End DoDot:1
Q3 ; unlock if appropriate, kill variables
+1 IF $$ORVR^RAORDU()'<3
IF (+$GET(RAPTLOCK))
IF (+$GET(RADFN))
Begin DoDot:1
+2 DO ULK^RAUTL19(RADFN_";DPT(")
End DoDot:1
+3 KILL %,%DT,C,D,D0,DA,POP,RADFN,RADIV,RAMSG,RANME,RAOFNS,RAOIFN,RAOLP
+4 KILL RAOPTN,RAORDS,RAOSTS,RAOVSTS
IF $DATA(RAPKG)
KILL OREND,RAPKG
+5 IF '$DATA(N)!($DATA(RAOREA)<10)
KILL RAPARENT,X,Y
+6 IF '$DATA(N)!($DATA(RAOREA)<10)
KILL RAOREA
GOTO Q35
+7 IF $DATA(RAOREA)>1
IF $GET(N)
KILL RAOREA(N),N
IF $DATA(RAOREA)<10
KILL RAOREA
+8 KILL RAPARENT,X,Y
Q35 KILL DIPGM,I
+1 QUIT
CHECK ; Check on the status of the order
+1 SET OREND=$SELECT(ORSTS=5:0,ORSTS=11:0,1:1)
if OREND
WRITE !!,"Only orders in a Pending or Unreleased status can be cancelled.",$CHAR(7)
+2 QUIT
REASON ; Select a Cancel Reason
+1 SET DIC("A")="Select CANCEL REASON: "
SET DIC("S")="I $P(^(0),U,2)=1!($P(^(0),U,2)=9)"
SET DIC="^RA(75.2,"
SET DIC(0)="AEMQ"
+2 WRITE !
DO ^DIC
KILL DIC
+3 IF +Y<0
IF (X["^")
SET RAXIT=1
QUIT
+4 IF +Y<0
WRITE !!?3,"A Cancel Reason is required to proceed."
GOTO REASON
+5 SET OREND=0
SET RAOREA($SELECT($DATA(ORPK):ORPK,$DATA(ORIFN):ORIFN,1:1))=+Y
+6 QUIT
4 ;;Hold a Request
+1 NEW RAPTLOCK
40 ; Patient lookup
+1 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO Q4
+2 IF $$ORVR^RAORDU()'<3
Begin DoDot:1
+3 SET RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
+4 QUIT
End DoDot:1
if 'RAPTLOCK
GOTO 40
+5 SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
+6 SET (RAOFNS,RAOPTN)="Hold"
SET RAOVSTS="5;8"
+7 WRITE !
DO ^RAORDS
if '$DATA(RAORDS)
GOTO Q4
41 ; Select a Hold Reason
+1 SET DIC("A")="Select HOLD REASON: "
SET DIC("S")="I $P(^(0),U,2)=3!($P(^(0),U,2)=9)"
SET DIC="^RA(75.2,"
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
+2 IF +Y<0
IF (X["^")
DO Q4
QUIT
+3 IF +Y<0
WRITE !!?3,"A Hold Reason is required to proceed."
GOTO 41
+4 SET RAOREA=+Y
+5 WRITE !?3,"...will now 'HOLD' selected request(s)..."
SET RAOLP=0
+6 FOR
SET RAOLP=+$ORDER(RAORDS(RAOLP))
if 'RAOLP!('+$GET(RAORDS(RAOLP)))
QUIT
Begin DoDot:1
+7 SET RAOIFN=$GET(RAORDS(RAOLP))
SET RAOSTS=3
DO ^RAORDU
+8 IF $DATA(^RAO(75.1,RAOIFN,0))
IF $DATA(^RAMIS(71,+$PIECE(^(0),"^",2),0))
WRITE !?10,"...",$PIECE(^(0),"^")," held..."
+9 QUIT
End DoDot:1
+10 DO Q4
GOTO 40
Q4 ; unlock if appropriate, kill variables
+1 IF $$ORVR^RAORDU()'<3
IF (+$GET(RAPTLOCK))
IF (+$GET(RADFN))
Begin DoDot:1
+2 DO ULK^RAUTL19(RADFN_";DPT(")
End DoDot:1
+3 KILL %DT,C,D,D0,DA,I,POP,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS
+4 KILL RAOPTN,RAOREA,RAOSTS,RAOVSTS,X,Y
+5 KILL D1,DDER,DI,DIPGM,DISYS,DUOUT,RAPARENT,^TMP($JOB,"PRO-ORD"),^("XQALSET")
+6 QUIT
+7 ;
6 ;;Udate a HOLD REASON /RA*5*133
+1 NEW RAPTLOCK
60 ; Patient lookup
+1 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO 64
+2 SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
+3 SET (RAOFNS,RAOPTN)="Update hold reason"
SET RAOVSTS="3"
+4 WRITE !
DO ^RAORDS
if '$DATA(RAORDS)
GOTO 64
61 ; Select a Hold Reason
+1 ;p168 - change lookup to catch types hold and general (3&9)
+2 SET DIC("A")="Select HOLD REASON: "
SET DIC("S")="I $P(^(0),U,2)=3!($P(^(0),U,2)=9)"
SET DIC="^RA(75.2,"
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
+3 IF +Y<0
IF (X["^")
DO 64
QUIT
+4 IF +Y<0
WRITE !!?3,"A Hold Reason is required to proceed."
GOTO 61
+5 SET RAOREA=+Y
+6 WRITE !?3,"...will now update the hold reason for the selected request(s)..."
SET RAOLP=0
+7 FOR
SET RAOLP=+$ORDER(RAORDS(RAOLP))
if 'RAOLP!('+$GET(RAORDS(RAOLP)))
QUIT
Begin DoDot:1
+8 SET RAOIFN=$GET(RAORDS(RAOLP))
SET RAOSTS=3
DO ^RAORDU
+9 IF $DATA(^RAO(75.1,RAOIFN,0))
IF $DATA(^RAMIS(71,+$PIECE(^(0),"^",2),0))
WRITE !?10,"...",$PIECE(^(0),"^")," updated..."
+10 QUIT
End DoDot:1
+11 DO 64
GOTO 60
64 ; unlock if appropriate, kill variables
+1 KILL %DT,C,D,D0,DA,I,POP,RADFN,RADIV,RANME,RAOFNS,RAOIFN,RAOLP,RAORDS
+2 KILL RAOPTN,RAOREA,RAOSTS,RAOVSTS,X,Y
+3 KILL D1,DDER,DI,DIPGM,DISYS,DUOUT,RAPARENT,^TMP($JOB,"PRO-ORD"),^("XQALSET")
+4 QUIT
+5 ;
9 ;;Print Selected Requests by Patient
+1 KILL ^TMP($JOB,"RA PRINT HS BY PAT")
+2 SET DIC="^DPT("
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO Q9
SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
SET RAOFNS="Print"
SET RAOVSTS="1;2;3;5;6;8"
WRITE !
DO ^RAORDS
if '$DATA(RAORDS)
GOTO Q9
+3 SET RAOIFNS=""
FOR RAOLP=1:1
if '$DATA(RAORDS(RAOLP))
QUIT
SET RAOIFNS=RAOIFNS_+RAORDS(RAOLP)_";"
+4 WRITE !
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+5 SET DIR(0)="Y"
SET DIR("B")="No"
+6 SET DIR("?")="Answer 'Y'es to print the report, 'N'o to quit."
+7 SET DIR("A")="Do you wish to generate a Health Summary Report"
+8 DO ^DIR
if $DATA(DIRUT)
GOTO Q9
SET RAGMTS=+Y
+9 SET ZTRTN="START9^RAORD"
SET ZTSAVE("RADFN")=""
SET ZTSAVE("RAOIFNS")=""
+10 SET ZTSAVE("RAGMTS")=""
if $DATA(RAOPT)
SET ZTSAVE("RAOPT(")=""
+11 WRITE !
DO ZIS^RAUTL
if RAPOP
GOTO Q9
+12 ;
START9 ; Start printing requests
+1 USE IO
SET RAX=""
NEW RA751
+2 FOR RAOLP=1:1
SET RAOIFN=$PIECE(RAOIFNS,";",RAOLP)
if 'RAOIFN!(RAX["^")
QUIT
Begin DoDot:1
+3 SET RAPGE=0
DO ^RAORD5
if RAX["^"
QUIT
+4 DO CRCHK^RAORD6
if RAX["^"
QUIT
+5 ; quit if 'No' to 'generate a Health Summary Report'.
if 'RAGMTS
QUIT
+6 SET RA751(0)=$GET(^RAO(75.1,RAOIFN,0))
SET RA751(2)=$PIECE(RA751(0),"^",2)
+7 SET GMTSTYP=$PIECE($GET(^RAMIS(71,+RA751(2),0)),"^",13)
+8 IF GMTSTYP>0
IF ('$DATA(^TMP($JOB,"RA PRINT HS BY PAT",GMTSTYP,RADFN)))
Begin DoDot:2
+9 if $Y>0
WRITE @IOF
DO ENX^GMTSDVR(RADFN,GMTSTYP)
+10 SET ^TMP($JOB,"RA PRINT HS BY PAT",GMTSTYP,RADFN)=""
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
Q9 KILL %DT,C,D,D0,DA,DFN,GMTSTYP,I,POP,RACNI,RADFN,RADIV,RADTI,RANME,RAOFNS
+1 KILL RAOIFN,RAOIFNS,RAOLP,RAORDS,RAOSTS,RAOVSTS,RAPARENT,RAPGE,RAPOP,RAX
+2 KILL RAGMTS,VAI,VAIN,X,Y,Z,^TMP($JOB,"RA PRINT HS BY PAT")
+3 KILL RAMES,ZTDESC,ZTRTN,ZTSAVE
+4 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+5 KILL DIPGM,DISYS,DIW,DIWT,DN,RA6,RA7,^TMP($JOB,"PRO-ORD")
+6 WRITE !
DO CLOSE^RAUTL
+7 QUIT
KILL ; kill variables - called from RAORD1
+1 KILL %,%DT,D,D0,D1,DA,DFN,DIC,DIK,DIROUT,DIRUT,DIV,DR,DTOUT,DUOUT,DWPK,J,OREND,RABLNK,RACNT,RACT,RADIV,RAEXMUL,RAFIN,RAFIN1,RAI,RAILOC,RAIMGTYI,RAIP,RAJ,RAL0,RALOC,RALIFN,RALOCFLG
+2 KILL RAMOD,RAMT,RANUM,RAOIFN,RAORD0,RAOUT,RAPIFN,RAPRC,RAPRI,RAPREG,RAPREOP1,RAREASK,RAREQDT,RAREQPRT,RARU,RARX,RASEQ,RAS3,RASEX,RASKPREG,RASTOP,RASX,RAWHEN,RAX,VAERR,VA200,VAI,VAIP,X,Y
+3 KILL RAACI
+4 ;don't kill clin hist if order entry quick orders not all proccessed
IF '$DATA(RAPKG)
IF $GET(XQORS)>1
IF $GET(^TMP("XQORS",$JOB,XQORS-1,"ITM"))'=$GET(^("TOT"))
QUIT
+5 KILL ^TMP($JOB,"RAWP")
+6 QUIT
PCR ; Print Cancelled Requests. Called from the 'Cancel A Request' option.
+1 NEW I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 SET ZTDESC="Rad/Nuc Med Cancelled Request Print"
SET ZTDTH=$HOROLOG
SET ZTIO=RAION
+3 SET ZTRTN="^RAORD5"
+4 FOR I="RACRHD","RADFN","RAOIFN","RAPGE","RAX"
SET ZTSAVE(I)=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!?3,$CHAR(7),"Task "_ZTSK_": cancellation queued to print on device ",RAION,!
+6 DO HOME^%ZIS
+7 QUIT
+8 ;
MAXDD(ARY) ;for the RIS orders (#75.1) selected by the user
+1 ;determine the DATE DESIRED (DD) farthest into the future.
+2 ;R = the DATE DESIRED farthest into the future
+3 ;X = 0 node (75.1) | X21 = RIS order DD
+4 ;Y = 'n' sequntial | ARY(Y) = record IEN (75.1)
+5 NEW R,X,Y
SET (R,Y)=0
FOR
SET Y=$ORDER(ARY(Y))
if Y'>0
QUIT
Begin DoDot:1
+6 SET X=$GET(^RAO(75.1,ARY(Y),0))
SET X21=$PIECE(X,U,21)
+7 if X21>R
SET R=X21
+8 QUIT
End DoDot:1
+9 ;FM internal
QUIT R
+10 ;
RESCH(Y) ;P174 - pass back subject and request statuses depending
+1 ;on the action: 'schedule request(s)' or 're-schedule request(s)'
+2 ;Input: 'Y': '1' for schedule, '2' for reschedule
+3 ;
+4 NEW X
SET X="Schedule^"
+5 QUIT $SELECT(Y=2:"Re-"_X_"8;",1:X_"3;5")
+6 ;
OUTXDAYS(RAPD,RAQD,RAMAX) ;P174 - compare two dates. Are they
+1 ; within the max # of days allowed?
+2 ;
+3 ; Input: RAMAX = The number of days one date must be within
+4 ; another. For example: RAMAX = 210
+5 ; RAPD = Primary Date
+6 ; For Example: 'DATE DESIRED (Not guaranteed)'
+7 ; RAQD = Questionable Date
+8 ; For Example: 'SCHEDULED DATE (TIME optional)'
+9 ; (RAOSCH is the variable for this fld)
+10 ;
+11 ;Return: one (1) if the difference between RAQD and RAPD is more than
+12 ; the max # of days (RAMAX)
+13 ; zero (0) if RAQD is less than or equal to the RAPD by RAMAX
+14 ;
+15 QUIT $SELECT(($$FMDIFF^XLFDT(RAQD,RAPD,1)>RAMAX):1,1:0)
+16 ;
