- 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 Feb 19, 2025@00:04:18 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 ;