PSGOEF ;BIR/CML - FINISH ORDERS ENTERED THROUGH OE/RR ;12 June 2019 09:31:53
;;5.0;INPATIENT MEDICATIONS;**7,30,29,35,39,47,50,56,80,116,110,111,133,153,134,222,113,181,260,199,281,315,256,373,327,372**;16 DEC 97;Build 153
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 via DBIA 2191
; Reference to ^PSDRUG( via DBIA 2192
; Reference to DOSE^PSSORPH via DBIA 3234
; Reference to ^TMP("PSODAOC",$J via DBIA 6071
; Reference to FULL^VALM1 via DBIA 10116
; Reference to ^PS(50.7 via DBIA# 2180
;
START ;
I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#",+PSGORD,")." Q
D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
I $G(CLOZFLG),'$D(CLOZPAT) D CLOZPAT^PSJCLOZ
I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJCOI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD)
I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 D
.S:($D(X)&($P($G(^PS(53.1,+PSGORD,2)),"^",5)="")&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="N")) PSGAT=PSGS0Y
.N PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X
.S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X
.D DOSE^PSSORPH(.PSJDOX,+X,"U")
.I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q
.S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1)
.S X=^PS(53.1,+PSGORD,.2)
.S:PSJPIECE=3 PSJDOSE=$P(X,U,2)
.S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6)
.F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X D
..I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q
..I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)) Q
..S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X),U,12),PSJX=1
I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
D GTST^PSGOE6(+PSGORD)
I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]""
.N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q
.I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q
.I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q
.I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2)
S:PSGSD="" PSGSD=PSGLI
S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD)
S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST ; N PSGOEA S PSGOEA="R"
ZZ S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD)
;; START NCC REMEDIATION >> 327*RJS - next line has been added
I $G(CLOZFLG) D COMPLEX1^PSJCLOZ
;if this is a renewal order, ignore any 'requested start date' received. Use the system calculated start date.
I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D
. D REQDT^PSJLIVMD(PSGORD)
E D
. S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNESD,PSGSD)=X K PSGRSD
D ; Extend the Default Stop Date if needed for the first renewed order.
.N PSGOEAO,PSGWALLO
.I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSGWALLO=$P(^PS(55,DFN,5.1),U)
.D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
.I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,5.1),U)=PSGWALLO
N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D
. N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN)
;S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD) ; #373
S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC2^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC2^PSGMI(PSGFD) ; #373
S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
I '$$GET1^DIQ(53.4502,"1,"_PSJSYSP,.01,"I") N DRG,DRGCNT S DRGCNT=0 D
.F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1) S:$P($G(^PSDRUG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X
.I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)=""
Q
FINISH ;
; force display of second screen if CPRS order checks exist
N NSFF,PSGOEF39,PSGEDTOI S NSFF=1 K PSJNSS,PSGEDTOI,PSGOEER,ZZND
N PSJRMABT,PSJOLDNM
I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D K PSGRDTX
.;PSJOCDSC stores the default start & stop date ^ cal start & stop date (use in dosing calculation for duration)
.;for some reasons PSGSD & PSGFD are reset to the cal dates if order has duration defined
.S PSJOCDSC("CX","PSGSD",+PSGORD)=$G(PSGSD)_U_$G(PSGRDTX(+PSGORD,"PSGRSD"))
.S PSJOCDSC("CX","PSGFD",+PSGORD)=$G(PSGFD)_U_$G(PSGRDTX(+PSGORD,"PSGRFD"))
.S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD")
.S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD))
N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8)
;
; PSJ*5*222
; PSJCT1 is a counter variable. Every piece of a complex order calls PSGOEF.
; The only time this code is to look for overlapping admin times is when the
; first part of a complex order is being finished. This variable will keep track
; of how many "parts" of the complex order have been checked.
;
; Also, since the user can select multiple complex orders to finish, like selecting
; orders 1-2 or 1-3 from the profile, PSJCT1A will keep track of whether the parent
; order number is the same as the first parent order number selected for finishing.
; Since the PSJCT1 counter variable will still be set if multiple complex orders
; are selected, PSJCT1 will be re-set to 1 if the parent complex order number (PSJCT1A) is
; not equal to the original parent order number (PSJCOM).
;
S PSJCT1=$G(PSJCT1)+1
I PSJCT1=1 S PSJCT1A=PSJCOM
I $G(PSJCT1A)'=PSJCOM S PSJCT1=1,PSJCT1A=PSJCOM
; End of flag setting for PSJ*5*222
D FULL^VALM1
;; START NCC REMEDIATION >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
I PSGSTAT'="ACTIVE",PSGSTAT'="NON-VERIFIED",PSGSTAT'="DISCONTINUED",$G(CLOZFLG) D I $G(ANQX) Q
.N PSGDRG S PSGDRG=$P(CLOZFLG,U,2)
.S ANQX=0 D CLOZ^PSJCLOZ(PSGP,PSGDRG)
.I $G(ANQX) K DIR S DIR(0)="E" D ^DIR K DIR
;; END NCC REMEDIATION << 327*RJS
I '$D(IOINORM)!('$D(IOINHI)) S X="IORVOFF;IORVON;IOINHI;IOINORM" D ENDR^%ZISS
I $G(PSJCOM)'="",$G(PSJCT1)=1 D
. D OVERLAP^PSGOEF2 I $G(PSJOVRLP)=1 D
. . N X,X1,DIR
. . W !!,"**WARNING**"
. . W !,"The highlighted admin times for these portions of this complex order overlap.",!!
. . S (X,X1)="" F S X=$O(^TMP("PSJATOVR",$J,X)) Q:X="" D
. . . S X1=$G(^TMP("PSJATOVR",$J,X))
. . . W $S($P(X1,"^",4)=1:IORVON,1:""),"Part "_X,IORVOFF," has a schedule of "_$P(X1,"^",2)_" and admin time(s) of "
. . . W $S($P(X1,"^",4)=1:IORVON,1:""),$P(X1,"^",3),IORVOFF
. . . W !
. . . W $S($G(PSJOVR("CONJ",X))="A":"AND",$G(PSJOVR("CONJ",X))="T":"THEN",1:""),!
. . W !,"Please ensure the schedules and administration times are appropriate.",!
. . S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
K ^TMP("PSJATOVR",$J)
I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q
;*** PSJ*5*256
S PSJOLDNM("ORD_SCHD")=PSGOSCH
I $$CHKSCHD^PSJMISC2(.PSJOLDNM,$S($P($G(^PS(53.1,+PSGORD,0)),U,24)="R":"R",1:"")) S PSGORQF=1,VALMBCK="R" D DONE Q
S:$G(PSJOLDNM("NEW_SCHD"))]"" PSGSCH=PSJOLDNM("NEW_SCHD")
I $G(PSGOSCH)]"" D S:$G(PSGS0XT)'="" $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
.N PSGOES,PSGS0Y,PSGSCH S X=$S($G(PSJOLDNM("NEW_SCHD"))]"":PSJOLDNM("NEW_SCHD"),1:PSGOSCH) K:$G(PSJTUD) NSFF D ENOS^PSGS0
.I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]""&$G(PSGS0Y) S:$G(PSGAT)="" PSGAT=PSGS0Y
.I $G(PSJNSS) S PSGOSCH="" K PSJNSS
.I $G(PSGORD)["P",$G(PSGAT),$G(PSGS0Y),($G(PSGOSCH)]"") I PSGAT'=PSGS0Y D
..S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE: This order's admin times (",PSGAT,")"
..W !?13," do not match the ward times (",PSGS0Y,")"
..W !?13," for this administration schedule (",$S($G(PSJOLDNM("NEW_SCHD"))]"":PSJOLDNM("NEW_SCHD"),1:PSGOSCH),")",!
..S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR W !
I $G(PSGS0XT)="" S $P(^PS(53.1,+PSGORD,2),"^",6)=$S($P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:"")
S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI)
I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0XT) K PSJNSS S PSGOSCH=""
S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10)
I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")
I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGOEFF=1,PSGOEF39=1
; *315 DRP If removal flag in 50.7 is a 2 or a 3 then order must be reviewed and removal times entered if required.
S PSGRF=$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I")
; Abort Finish process if no Stop Date entered ($G(PSJRMABT))
N SCHARR D FIND^DIC(51.1,,"5I","X",$G(PSGSCH),,"APPSJ",,,"SCHARR")
I $G(PSGRF),$G(PSGDUR)="",'$G(PSGRMV),$G(SCHARR("DILIST",0)) S PSJRMABT=0 D I PSJRMABT D ABORTACC Q
. N PSGTMPST S PSGTMPST=$S($G(PSGST)="R":$G(SCHARR("DILIST","ID",1,5)),1:$G(PSGST)) ;Handle "Fill on Request"
. I ($G(PSGTMPST)'="O"),($G(PSGTMPST)'="P"),($G(PSGTMPST)'="OC"),+$G(PSGRF)>1 S X="",PSGOEFF=1,PSGOEF39=1
. I $G(PSGTMPST)="O" S (PSGFDN,PSGFD)="" D
.. S F1=53.1,MSG=0,Y=$T(35),@("PSGFN(35)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(35),";",3) S CHK=0 I 'PSGOEE S PSJRMABT=1
.. W:PSJRMABT $C(7),!!,"INVALID STOP DATE" S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR W !
..Q
.Q
;
I PSGOEFF,X]"" S X=X_" before it can be finished."
I PSGOEFF,X]"" S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," "
I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D I 'PSGOEE D REFRESH^VALM G DONE
.S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0
.I $G(PSGRMVT),'PSGOEE D INIT^PSJLMUDE($G(PSGP),$G(PSGORD)) ;*315 IF REMOVE TIME SET THEN REDISPLAY DETAIL
.Q
I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G:'PSGOEE DONE
I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D G:'PSGOEE DONE
.S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0
I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q
I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS
S VALMBG=1
I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q
I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD)
S PSJLMFIN=1
K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1
S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED")
NEW PSJDOSE,PSJDOX,PSJDSFLG
D DOSECHK^PSJDOSE
S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatible"
I PSGODO=PSGDO S PSGOEEF(109)=""
I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order to be created "
;I $G(PSGPDN)["CLOZ",+$G(PSGCOMP) D COMPLEX^PSJCLOZ ;; RJS*327
D EN^VALM("PSJU LM ACCEPT")
I $G(PSJNSS) D S PSGOEEF(26)="" K PSJACEPT,PSJNSS
.K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR
I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_",")) D S PSGOEEF(39)="" K PSJACEPT
.K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules " D ^DIR K DIR
;***PSJ*5*113
;; START NCC REMEDIATION >> 327*RJS
I $G(PSJACEPT) D I $G(PSGORQF) D ABORTACC Q
.I $G(PSGCLZ)!(+$G(PSGRDTX)) D
..I $G(CLOZFLG) D
...S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DIR K DIR I $D(DIRUT) S (CHK,PSGORQF)=1 Q ;G DONE:$G(CHK)
...S (^TMP("PSJCOM",$J,+PSGORD,"SAND"),PSOSAND)=X
...D CLOZPAT^PSJCLOZ
...S X1=PSGSD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,$G(CLOZPAT)=3:4,1:90)
...D C^%DTC I $G(PSGFD),$G(PSGFD)'>X Q ; added by MZR to not override an existing Stop Date/Time
...S PSGFD=X,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
;; END NCC REMEDIATION >> 327*RJS
I $G(PSGAT)="",(PSGST="C"!(PSGST="R")) D
.I $G(PSGS0XT) Q:$$ODD^PSGS0(PSGS0XT)
.Q:$$PRNOK^PSGS0($G(PSGSCH))
.Q:($P($G(ZZND),"^",5)'="C")
.K PSJACEPT
.K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for CONTINUOUS orders " D ^DIR K DIR
;***
I '$G(PSJACEPT) D ABORTACC Q
I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D
. W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE."
. S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order,"
. S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR S:'Y Y=-1 K DIR
I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q
I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1
I $G(PSGEDTOI) D OC^PSJOE1
I $S($G(PSGORQF):0,$G(PSGEDTOI):0,$G(PSGOEER)["109^PSGOE8":1,$G(PSGOEER)["3^PSGOE8":1,$G(PSGOEER)["26^PSGOE8":1,$G(PSGOEER)["10^PSGOE81":1,$G(PSGOEER)["25^PSGOE81":1,1:0) D
. NEW PSJDD S PSJDD=+$$DD53P45^PSJMISC()
. D:$G(PSJDD) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
I $G(PSGORQF) S PSGOEENO=0,PSJACEPT=0
I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1)
ACCEPT ;
N PSGUDFIN S PSGUDFIN=1
S VALMBCK=$S($G(PSJACEPT):"Q",1:"R")
I '$G(PSJACEPT) D ABORTACC Q
;*** PSJ*5*256
I $G(PSJOLDNM("NEW_SCHD"))]"" S PSGSCH=$G(PSJOLDNM("NEW_SCHD")),PSGOEENO=1,PSGOEEF(26)=1,PSJNOO="S"
K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1
;saves drug allergy signs/symptoms PSJ*5*260
I $D(^TMP("PSODAOC",$J,"ALLERGY")) D
.N DA,OCCDT,ORN,ORL,Z,RET,PSJDAOC
.S PSJDAOC="IP "_$S($G(PSGORD)["P":"Pending/Non-Verified",$G(PSGORD)["U":"Unit Dose",$G(PSGORD)["V":"IV",1:"")_" Allergy",OCCDT=$$NOW^XLFDT
.I PSGORD["P" S ORN=$P(^PS(53.1,+PSGORD,0),U,21)
.I PSGORD["U" S ORN=$P(^PS(55,DFN,5,+PSGORD,0),U,21)
.I PSGORD["V" S ORN=$P(^PS(55,DFN,"IV",+PSGORD,0),U,21)
.Q:'$G(ORN)
. S PSJAGYSV=1 ;use in ^PSJOE to store allergy (also clean up this var)
.;D SETOC^PSJNEWOC(PSGORD) ;set order checks in 100.05
.;K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
D DONE1^PSGOEE
D DONE
Q
BYPASS ;
S PSGCANFL=1
;
DONE ;
K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT,PSGEDTOI,PSGOEER,ZZND
K PSJOVR
Q
ABORTACC ; Abort Accept process.
;*315
K PSGDUR,PSGRMVT,PSGRMV,PSGRF
K PSJCT1,PSJOVR,PSJOVRLP,PSJCT1A K ^TMP("PSODAOC",$J) ;,^TMP("PSGCPLX",$J,$G(DFN))
D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGNESD,PSGFD=PSGNEFD Q
;
;
31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1
32 ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]""
33 ;;10^PSGOE81;PSGOSD;PSGSD;10;0
34 ;;3^PSGOE8;PSGOMR;PSGMR;3;1
35 ;;25^PSGOE81;PSGOFD;PSGFD;25;0
36 ;;7^PSGOE8;PSGOST;PSGST;7;0
37 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
38 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1
39 ;;39^PSGOE81;PSGOAT;PSGAT;39;0
310 ;;1^PSGOE82;PSGOPR;PSGPR;1;1
311 ;;8^PSGOE81;PSGOSI;PSGSI;8;0
312 ;;2^PSGOE82;;;2;0
313 ;;40^PSGOE82;;;40;0
;
AH ;
W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order. Answer",!,"'NO' to edit this order now. Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEF 15478 printed Dec 13, 2024@02:02:09 Page 2
PSGOEF ;BIR/CML - FINISH ORDERS ENTERED THROUGH OE/RR ;12 June 2019 09:31:53
+1 ;;5.0;INPATIENT MEDICATIONS;**7,30,29,35,39,47,50,56,80,116,110,111,133,153,134,222,113,181,260,199,281,315,256,373,327,372**;16 DEC 97;Build 153
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 via DBIA 2191
+4 ; Reference to ^PSDRUG( via DBIA 2192
+5 ; Reference to DOSE^PSSORPH via DBIA 3234
+6 ; Reference to ^TMP("PSODAOC",$J via DBIA 6071
+7 ; Reference to FULL^VALM1 via DBIA 10116
+8 ; Reference to ^PS(50.7 via DBIA# 2180
+9 ;
START ;
+1 IF '$DATA(^PS(53.1,+PSGORD))
WRITE $CHAR(7),!?3,"Cannot find this pending order (#",+PSGORD,")."
QUIT
+2 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
KILL PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX
SET PSGOES=1
SET (PSGOEF,PSGOEEF)=0
SET PSGOEEG=3
+3 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
+4 IF $GET(CLOZFLG)
IF '$DATA(CLOZPAT)
DO CLOZPAT^PSJCLOZ
+5 IF $DATA(PSJTUD)
SET PSGDO=$PIECE($GET(^PS(53.1,+PSGORD,.3)),U)
SET (PSGPDRG,PSGPD)=PSJCOI
SET (PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD)
+6 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
SET X=PSGSCH
DO EN^PSGORS0
Begin DoDot:1
+7 if ($DATA(X)&($PIECE($GET(^PS(53.1,+PSGORD,2)),"^",5)="")&($PIECE($GET(^PS(53.1,+PSGORD,0)),"^",24)="N"))
SET PSGAT=PSGS0Y
+8 NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X
+9 SET X=$GET(^PS(53.1,+PSGORD,1,1,0))
if '+X
QUIT
+10 DO DOSE^PSSORPH(.PSJDOX,+X,"U")
+11 IF $SELECT('$DATA(PSJDOX):1,1:+PSJDOX(1)=-1)
QUIT
+12 SET PSJPIECE=$SELECT($PIECE(PSJDOX(1),U)="":3,1:1)
+13 SET X=^PS(53.1,+PSGORD,.2)
+14 if PSJPIECE=3
SET PSJDOSE=$PIECE(X,U,2)
+15 if PSJPIECE=1
SET PSJDOSE=$PIECE(X,U,5)
SET PSJUNIT=$PIECE(X,U,6)
+16 FOR X=0:0
SET X=$ORDER(PSJDOX(X))
if +$GET(PSJX)!'X
QUIT
Begin DoDot:2
+17 IF PSJPIECE=3
IF ($PIECE(PSJDOX(X),U,3)'=PSJDOSE)
QUIT
+18 IF PSJPIECE=1
IF ($PIECE(PSJDOX(X),U,1)_$PIECE(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT))
QUIT
+19 if +$PIECE(PSJDOX(X),U,12)
SET $PIECE(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$PIECE(PSJDOX(X),U,12)
SET PSJX=1
End DoDot:2
End DoDot:1
+20 IF PSGEB'=PSGOPR
FOR X=7,11
SET Y=$TEXT(@(3_X))
SET @("PSGEFN("_X_")="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=""
SET PSGOEEF=PSGOEEF+1
+21 DO GTST^PSGOE6(+PSGORD)
+22 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
SET PSGSD=""
if PSGS0Y]""
Begin DoDot:1
+23 NEW PSJX
SET PSJX=$PIECE($GET(^PS(53.1,+PSGORD,0)),U,25)
IF PSJX=""
QUIT
+24 IF PSJX["U"
SET PSGSD=$PIECE($GET(^PS(55,DFN,5,+PSJX,2)),U,2)
QUIT
+25 IF PSJX["V"
SET PSGSD=$PIECE($GET(^PS(55,DFN,"IV",+PSJX,0)),U,2)
QUIT
+26 IF PSJX["P"
SET PSGSD=$PIECE($GET(^PS(53.1,+PSJX,2)),U,2)
End DoDot:1
+27 if PSGSD=""
SET PSGSD=PSGLI
+28 SET PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD)
+29 ; N PSGOEA S PSGOEA="R"
if $PIECE($GET(PSGNEDFD),U,3)=""
SET $PIECE(PSGNEDFD,U,3)=PSGST
ZZ SET (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD)
+1 ;; START NCC REMEDIATION >> 327*RJS - next line has been added
+2 IF $GET(CLOZFLG)
DO COMPLEX1^PSJCLOZ
+3 ;if this is a renewal order, ignore any 'requested start date' received. Use the system calculated start date.
+4 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
Begin DoDot:1
+5 DO REQDT^PSJLIVMD(PSGORD)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET X=$$DSTART^PSJDCU(DFN,$PIECE(^PS(53.1,+PSGORD,0),U,25))
IF X]""
SET (PSGNESD,PSGSD)=X
KILL PSGRSD
End DoDot:1
+8 ; Extend the Default Stop Date if needed for the first renewed order.
Begin DoDot:1
+9 NEW PSGOEAO,PSGWALLO
+10 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
SET PSGOEAO=PSGOEA
SET PSGOEA="R"
SET PSGWALLO=$PIECE(^PS(55,DFN,5.1),U)
+11 DO ENFD^PSGNE3(PSGLI)
SET PSGFD=$SELECT($GET(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
+12 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
SET PSGOEA=PSGOEAO
SET $PIECE(^PS(55,DFN,5.1),U)=PSGWALLO
End DoDot:1
+13 NEW DUR,PSGRNSD
SET PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD)
IF PSGRNSD
SET DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1)
IF DUR]""
Begin DoDot:1
+14 NEW DURMIN
SET DURMIN=$$DURMIN^PSJLIVMD(DUR)
IF DURMIN
SET PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN)
End DoDot:1
+15 ;S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD) ; #373
+16 ; #373
SET PSGOFD=""
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC2^PSGMI(PSGSD)
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC2^PSGMI(PSGFD)
+17 SET PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
+18 IF '$$GET1^DIQ(53.4502,"1,"_PSJSYSP,.01,"I")
NEW DRG,DRGCNT
SET DRGCNT=0
Begin DoDot:1
+19 FOR X=0:0
SET X=$ORDER(^PSDRUG("ASP",+PSGPD,X))
if 'X!(DRGCNT>1)
QUIT
if $PIECE($GET(^PSDRUG(+X,2)),U,3)["U"
SET DRGCNT=DRGCNT+1
SET DRG=+X
+20 IF DRGCNT=1
KILL ^PS(53.45,PSJSYSP,2)
SET ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1
SET ^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1"
SET PS(53.45,PSJSYSP,2,"B",+DRG,1)=""
End DoDot:1
+21 QUIT
FINISH ;
+1 ; force display of second screen if CPRS order checks exist
+2 NEW NSFF,PSGOEF39,PSGEDTOI
SET NSFF=1
KILL PSJNSS,PSGEDTOI,PSGOEER,ZZND
+3 NEW PSJRMABT,PSJOLDNM
+4 IF $GET(PSGORD)
IF $DATA(PSGRDTX(+PSGORD))
Begin DoDot:1
+5 ;PSJOCDSC stores the default start & stop date ^ cal start & stop date (use in dosing calculation for duration)
+6 ;for some reasons PSGSD & PSGFD are reset to the cal dates if order has duration defined
+7 SET PSJOCDSC("CX","PSGSD",+PSGORD)=$GET(PSGSD)_U_$GET(PSGRDTX(+PSGORD,"PSGRSD"))
+8 SET PSJOCDSC("CX","PSGFD",+PSGORD)=$GET(PSGFD)_U_$GET(PSGRDTX(+PSGORD,"PSGRFD"))
+9 if $GET(PSGRDTX(+PSGORD,"PSGRSD"))
SET PSGSD=PSGRDTX(+PSGORD,"PSGRSD")
+10 if $GET(PSGRDTX(+PSGORD,"PSGRFD"))
SET PSGFD=$SELECT($GET(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$GET(PSGNEFD))
End DoDot:1
KILL PSGRDTX
+11 NEW PSJCOM
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
+12 ;
+13 ; PSJ*5*222
+14 ; PSJCT1 is a counter variable. Every piece of a complex order calls PSGOEF.
+15 ; The only time this code is to look for overlapping admin times is when the
+16 ; first part of a complex order is being finished. This variable will keep track
+17 ; of how many "parts" of the complex order have been checked.
+18 ;
+19 ; Also, since the user can select multiple complex orders to finish, like selecting
+20 ; orders 1-2 or 1-3 from the profile, PSJCT1A will keep track of whether the parent
+21 ; order number is the same as the first parent order number selected for finishing.
+22 ; Since the PSJCT1 counter variable will still be set if multiple complex orders
+23 ; are selected, PSJCT1 will be re-set to 1 if the parent complex order number (PSJCT1A) is
+24 ; not equal to the original parent order number (PSJCOM).
+25 ;
+26 SET PSJCT1=$GET(PSJCT1)+1
+27 IF PSJCT1=1
SET PSJCT1A=PSJCOM
+28 IF $GET(PSJCT1A)'=PSJCOM
SET PSJCT1=1
SET PSJCT1A=PSJCOM
+29 ; End of flag setting for PSJ*5*222
+30 DO FULL^VALM1
+31 ;; START NCC REMEDIATION >> 327*RJS
+32 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
+33 IF PSGSTAT'="ACTIVE"
IF PSGSTAT'="NON-VERIFIED"
IF PSGSTAT'="DISCONTINUED"
IF $GET(CLOZFLG)
Begin DoDot:1
+34 NEW PSGDRG
SET PSGDRG=$PIECE(CLOZFLG,U,2)
+35 SET ANQX=0
DO CLOZ^PSJCLOZ(PSGP,PSGDRG)
+36 IF $GET(ANQX)
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
IF $GET(ANQX)
QUIT
+37 ;; END NCC REMEDIATION << 327*RJS
+38 IF '$DATA(IOINORM)!('$DATA(IOINHI))
SET X="IORVOFF;IORVON;IOINHI;IOINORM"
DO ENDR^%ZISS
+39 IF $GET(PSJCOM)'=""
IF $GET(PSJCT1)=1
Begin DoDot:1
+40 DO OVERLAP^PSGOEF2
IF $GET(PSJOVRLP)=1
Begin DoDot:2
+41 NEW X,X1,DIR
+42 WRITE !!,"**WARNING**"
+43 WRITE !,"The highlighted admin times for these portions of this complex order overlap.",!!
+44 SET (X,X1)=""
FOR
SET X=$ORDER(^TMP("PSJATOVR",$JOB,X))
if X=""
QUIT
Begin DoDot:3
+45 SET X1=$GET(^TMP("PSJATOVR",$JOB,X))
+46 WRITE $SELECT($PIECE(X1,"^",4)=1:IORVON,1:""),"Part "_X,IORVOFF," has a schedule of "_$PIECE(X1,"^",2)_" and admin time(s) of "
+47 WRITE $SELECT($PIECE(X1,"^",4)=1:IORVON,1:""),$PIECE(X1,"^",3),IORVOFF
+48 WRITE !
+49 WRITE $SELECT($GET(PSJOVR("CONJ",X))="A":"AND",$GET(PSJOVR("CONJ",X))="T":"THEN",1:""),!
End DoDot:3
+50 WRITE !,"Please ensure the schedules and administration times are appropriate.",!
+51 SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
WRITE !
End DoDot:2
End DoDot:1
+52 KILL ^TMP("PSJATOVR",$JOB)
+53 IF $GET(PSJPROT)=3
IF '$DATA(PSJTUD)
IF '$$ENIVUD^PSGOEF1(PSGORD)
QUIT
+54 ;*** PSJ*5*256
+55 SET PSJOLDNM("ORD_SCHD")=PSGOSCH
+56 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM,$SELECT($PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R":"R",1:""))
SET PSGORQF=1
SET VALMBCK="R"
DO DONE
QUIT
+57 if $GET(PSJOLDNM("NEW_SCHD"))]""
SET PSGSCH=PSJOLDNM("NEW_SCHD")
+58 IF $GET(PSGOSCH)]""
Begin DoDot:1
+59 NEW PSGOES,PSGS0Y,PSGSCH
SET X=$SELECT($GET(PSJOLDNM("NEW_SCHD"))]"":PSJOLDNM("NEW_SCHD"),1:PSGOSCH)
if $GET(PSJTUD)
KILL NSFF
DO ENOS^PSGS0
+60 IF '($GET(PSGORD)["P"&($PIECE($GET(^PS(53.1,+PSGORD,0)),"^",24)="R"))
IF $GET(X)]""&$GET(PSGS0Y)
if $GET(PSGAT)=""
SET PSGAT=PSGS0Y
+61 IF $GET(PSJNSS)
SET PSGOSCH=""
KILL PSJNSS
+62 IF $GET(PSGORD)["P"
IF $GET(PSGAT)
IF $GET(PSGS0Y)
IF ($GET(PSGOSCH)]"")
IF PSGAT'=PSGS0Y
Begin DoDot:2
+63 SET PSGNSTAT=1
WRITE $CHAR(7),!!,"PLEASE NOTE: This order's admin times (",PSGAT,")"
+64 WRITE !?13," do not match the ward times (",PSGS0Y,")"
+65 WRITE !?13," for this administration schedule (",$SELECT($GET(PSJOLDNM("NEW_SCHD"))]"":PSJOLDNM("NEW_SCHD"),1:PSGOSCH),")",!
+66 SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
KILL DIR
WRITE !
End DoDot:2
End DoDot:1
if $GET(PSGS0XT)'=""
SET $PIECE(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
+67 IF $GET(PSGS0XT)=""
SET $PIECE(^PS(53.1,+PSGORD,2),"^",6)=$SELECT($PIECE($GET(ZZND),"^",3)'="":$PIECE(ZZND,"^",3),1:"")
+68 SET CHK=0
if $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)'="R"
SET PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI)
+69 IF '$GET(PSJTUD)
IF $GET(PSJNSS)
IF ($GET(PSGOSCH)]"")
DO NSSCONT^PSGS0(PSGOSCH,PSGS0XT)
KILL PSJNSS
SET PSGOSCH=""
+70 SET PSGOEFF=PSGOSCH=""+('$ORDER(^PS(53.45,PSJSYSP,2,0))*10)
+71 IF PSGOEFF
SET X=$SELECT(PSGOEFF#2:" a SCHEDULE",1:"")_$SELECT(PSGOEFF=11:" and",1:"")_$SELECT(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")
+72 IF 'PSGOEFF
IF (($GET(PSGS0XT)="D")&($GET(PSGAT)=""))
SET X=" Admin Times"
SET PSGOEFF=1
SET PSGOEF39=1
+73 ; *315 DRP If removal flag in 50.7 is a 2 or a 3 then order must be reviewed and removal times entered if required.
+74 SET PSGRF=$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
+75 ; Abort Finish process if no Stop Date entered ($G(PSJRMABT))
+76 NEW SCHARR
DO FIND^DIC(51.1,,"5I","X",$GET(PSGSCH),,"APPSJ",,,"SCHARR")
+77 IF $GET(PSGRF)
IF $GET(PSGDUR)=""
IF '$GET(PSGRMV)
IF $GET(SCHARR("DILIST",0))
SET PSJRMABT=0
Begin DoDot:1
+78 ;Handle "Fill on Request"
NEW PSGTMPST
SET PSGTMPST=$SELECT($GET(PSGST)="R":$GET(SCHARR("DILIST","ID",1,5)),1:$GET(PSGST))
+79 IF ($GET(PSGTMPST)'="O")
IF ($GET(PSGTMPST)'="P")
IF ($GET(PSGTMPST)'="OC")
IF +$GET(PSGRF)>1
SET X=""
SET PSGOEFF=1
SET PSGOEF39=1
+80 IF $GET(PSGTMPST)="O"
SET (PSGFDN,PSGFD)=""
Begin DoDot:2
+81 SET F1=53.1
SET MSG=0
SET Y=$TEXT(35)
SET @("PSGFN(35)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEE,PSGOEEF)=1
WRITE !
DO @$PIECE($TEXT(35),";",3)
SET CHK=0
IF 'PSGOEE
SET PSJRMABT=1
+82 if PSJRMABT
WRITE $CHAR(7),!!,"INVALID STOP DATE"
SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
KILL DIR
WRITE !
+83 QUIT
End DoDot:2
+84 QUIT
End DoDot:1
IF PSJRMABT
DO ABORTACC
QUIT
+85 ;
+86 IF PSGOEFF
IF X]""
SET X=X_" before it can be finished."
+87 IF PSGOEFF
IF X]""
SET CHK=1
WRITE $CHAR(7),!!,"PLEASE NOTE: This order must have"
FOR Q=1:1:$LENGTH(X," ")
SET Y=$PIECE(X," ",Q)
if $LENGTH(Y)+$X>78
WRITE !
WRITE Y," "
+88 IF $GET(PSGOEF39)
SET PSGOEE=0
SET PSGOEFF=0
Begin DoDot:1
+89 SET F1=53.1
SET MSG=0
SET Y=$TEXT(39)
SET @("PSGFN(39)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEEF,PSGOEE)=1
WRITE !
DO @$PIECE($TEXT(39),";",3)
SET CHK=0
+90 ;*315 IF REMOVE TIME SET THEN REDISPLAY DETAIL
IF $GET(PSGRMVT)
IF 'PSGOEE
DO INIT^PSJLMUDE($GET(PSGP),$GET(PSGORD))
+91 QUIT
End DoDot:1
IF 'PSGOEE
DO REFRESH^VALM
GOTO DONE
+92 IF PSGOEFF=1
SET F1=53.1
SET MSG=0
SET Y=$TEXT(38)
SET @("PSGFN(38)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEE,PSGOEEF)=1
WRITE !
DO @$PIECE($TEXT(38),";",3)
SET CHK=0
if 'PSGOEE
GOTO DONE
+93 IF PSGOEFF=11
SET F1=53.1
SET MSG=0
SET Y=$TEXT(32)
SET @("PSGFN(32)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEE,PSGOEEF)=1
WRITE !
DO @$PIECE($TEXT(32),";",3)
Begin DoDot:1
+94 SET F1=53.1
SET MSG=0
SET Y=$TEXT(38)
SET @("PSGFN(38)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEE,PSGOEEF)=1
WRITE !
DO @$PIECE($TEXT(38),";",3)
SET CHK=0
End DoDot:1
if 'PSGOEE
GOTO DONE
+95 IF PSGOEFF>9
SET CHK=7
DO ENDRG^PSGOEF1(+PSGPD,0)
IF CHK
DO ABORTACC
QUIT
+96 ; check every dispense drug from CPRS
IF 'PSGOEFF
DO OC531^PSGOESF
+97 SET VALMBG=1
+98 IF 'PSGOEFF&($DATA(PSGORQF))
DO RE^VALM4
QUIT
+99 IF $GET(MSG)
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
+100 IF PSGOEFF
if PSGST=""
DO GTST^PSGOE6(+PSGORD)
+101 SET PSJLMFIN=1
+102 KILL PSJACEPT
IF $ORDER(^PS(53.1,+PSGORD,12,0))
SET PSJLMP2=1
+103 SET PSGOEENO=0
SET PSGSTAT=$SELECT($PIECE(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED")
+104 NEW PSJDOSE,PSJDOX,PSJDSFLG
+105 DO DOSECHK^PSJDOSE
+106 if +$GET(PSJDSFLG)
SET VALMSG="Dosage Ordered & Dispense Drug are not compatible"
+107 IF PSGODO=PSGDO
SET PSGOEEF(109)=""
+108 IF PSGODO'=PSGDO
SET PSGOEENO=1
SET VALMSG="This change will cause a new order to be created "
+109 ;I $G(PSGPDN)["CLOZ",+$G(PSGCOMP) D COMPLEX^PSJCLOZ ;; RJS*327
+110 DO EN^VALM("PSJU LM ACCEPT")
+111 IF $GET(PSJNSS)
Begin DoDot:1
+112 KILL DIR
SET DIR(0)="FOA"
SET DIR("A")="Invalid Schedule"
DO ^DIR
KILL DIR
End DoDot:1
SET PSGOEEF(26)=""
KILL PSJACEPT,PSJNSS
+113 IF $GET(PSGS0XT)="D"
IF '$GET(PSGS0Y)
IF '$GET(PSGAT)
IF ((",P,R,")'[(","_$GET(PSGST)_","))
Begin DoDot:1
+114 KILL DIR
SET DIR(0)="FOA"
SET DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules "
DO ^DIR
KILL DIR
End DoDot:1
SET PSGOEEF(39)=""
KILL PSJACEPT
+115 ;***PSJ*5*113
+116 ;; START NCC REMEDIATION >> 327*RJS
+117 IF $GET(PSJACEPT)
Begin DoDot:1
+118 IF $GET(PSGCLZ)!(+$GET(PSGRDTX))
Begin DoDot:2
+119 IF $GET(CLOZFLG)
Begin DoDot:3
+120 ;G DONE:$G(CHK)
SET DIR(0)="N^12.5:3000:1"
SET DIR("A")="CLOZAPINE dosage (mg/day) ? "
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET (CHK,PSGORQF)=1
QUIT
+121 SET (^TMP("PSJCOM",$JOB,+PSGORD,"SAND"),PSOSAND)=X
+122 DO CLOZPAT^PSJCLOZ
+123 SET X1=PSGSD
SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,$GET(CLOZPAT)=3:4,1:90)
+124 ; added by MZR to not override an existing Stop Date/Time
DO C^%DTC
IF $GET(PSGFD)
IF $GET(PSGFD)'>X
QUIT
+125 SET PSGFD=X
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
End DoDot:3
End DoDot:2
End DoDot:1
IF $GET(PSGORQF)
DO ABORTACC
QUIT
+126 ;; END NCC REMEDIATION >> 327*RJS
+127 IF $GET(PSGAT)=""
IF (PSGST="C"!(PSGST="R"))
Begin DoDot:1
+128 IF $GET(PSGS0XT)
if $$ODD^PSGS0(PSGS0XT)
QUIT
+129 if $$PRNOK^PSGS0($GET(PSGSCH))
QUIT
+130 if ($PIECE($GET(ZZND),"^",5)'="C")
QUIT
+131 KILL PSJACEPT
+132 KILL DIR
SET DIR(0)="FOA"
SET DIR("A")=" WARNING - Admin times are required for CONTINUOUS orders "
DO ^DIR
KILL DIR
End DoDot:1
+133 ;***
+134 IF '$GET(PSJACEPT)
DO ABORTACC
QUIT
+135 IF $GET(PSJRNF)
IF $GET(^PS(53.1,+PSGORD,4))
Begin DoDot:1
+136 WRITE $CHAR(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE."
+137 SET DIR(0)="Y"
SET DIR("A")="Do you wish to make this order Active"
SET DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order,"
+138 SET DIR("?")="or ""Y"" to continue with the Activation process."
DO ^DIR
if 'Y
SET Y=-1
KILL DIR
End DoDot:1
+139 IF $GET(PSJRNF)
IF $GET(Y)=-1
SET PSJACEPT=0
DO ABORTACC
QUIT
+140 IF $GET(PSJRNF)
IF $GET(Y)=1
SET PSGOEAV=1
+141 IF $GET(PSGEDTOI)
DO OC^PSJOE1
+142 IF $SELECT($GET(PSGORQF):0,$GET(PSGEDTOI):0,$GET(PSGOEER)["109^PSGOE8":1,$GET(PSGOEER)["3^PSGOE8":1,$GET(PSGOEER)["26^PSGOE8":1,$GET(PSGOEER)["10^PSGOE81":1,$GET(PSGOEER)["25^PSGOE81":1,1:0)
Begin DoDot:1
+143 NEW PSJDD
SET PSJDD=+$$DD53P45^PSJMISC()
+144 if $GET(PSJDD)
DO IN^PSJOCDS($GET(PSGORD),"UD",PSJDD)
End DoDot:1
+145 IF $GET(PSGORQF)
SET PSGOEENO=0
SET PSJACEPT=0
+146 IF PSGOEENO
SET PSJNOO=$$ENNOO^PSJUTL5("E")
SET PSJACEPT=$SELECT(PSJNOO<0:0,1:1)
ACCEPT ;
+1 NEW PSGUDFIN
SET PSGUDFIN=1
+2 SET VALMBCK=$SELECT($GET(PSJACEPT):"Q",1:"R")
+3 IF '$GET(PSJACEPT)
DO ABORTACC
QUIT
+4 ;*** PSJ*5*256
+5 IF $GET(PSJOLDNM("NEW_SCHD"))]""
SET PSGSCH=$GET(PSJOLDNM("NEW_SCHD"))
SET PSGOEENO=1
SET PSGOEEF(26)=1
SET PSJNOO="S"
+6 KILL PSGOES,PSGRSD,PSGRSDN
if PSGOEENO
DO NEW3^PSGOEE
if 'PSGOEENO
DO UPD^PSGOEF1
IF $DATA(PSGOEF)!PSGOEENO
SET PSGCANFL=-1
+7 ;saves drug allergy signs/symptoms PSJ*5*260
+8 IF $DATA(^TMP("PSODAOC",$JOB,"ALLERGY"))
Begin DoDot:1
+9 NEW DA,OCCDT,ORN,ORL,Z,RET,PSJDAOC
+10 SET PSJDAOC="IP "_$SELECT($GET(PSGORD)["P":"Pending/Non-Verified",$GET(PSGORD)["U":"Unit Dose",$GET(PSGORD)["V":"IV",1:"")_" Allergy"
SET OCCDT=$$NOW^XLFDT
+11 IF PSGORD["P"
SET ORN=$PIECE(^PS(53.1,+PSGORD,0),U,21)
+12 IF PSGORD["U"
SET ORN=$PIECE(^PS(55,DFN,5,+PSGORD,0),U,21)
+13 IF PSGORD["V"
SET ORN=$PIECE(^PS(55,DFN,"IV",+PSGORD,0),U,21)
+14 if '$GET(ORN)
QUIT
+15 ;use in ^PSJOE to store allergy (also clean up this var)
SET PSJAGYSV=1
+16 ;D SETOC^PSJNEWOC(PSGORD) ;set order checks in 100.05
+17 ;K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
End DoDot:1
+18 DO DONE1^PSGOEE
+19 DO DONE
+20 QUIT
BYPASS ;
+1 SET PSGCANFL=1
+2 ;
DONE ;
+1 KILL CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT,PSGEDTOI,PSGOEER,ZZND
+2 KILL PSJOVR
+3 QUIT
ABORTACC ; Abort Accept process.
+1 ;*315
+2 KILL PSGDUR,PSGRMVT,PSGRMV,PSGRF
+3 ;,^TMP("PSGCPLX",$J,$G(DFN))
KILL PSJCT1,PSJOVR,PSJOVRLP,PSJCT1A
KILL ^TMP("PSODAOC",$JOB)
+4 DO ABORT^PSGOEE
KILL PSGOEEF
DO GETUD^PSJLMGUD(PSGP,PSGORD)
DO ^PSGOEF
DO ENSFE^PSGOEE0(PSGP,PSGORD)
DO INIT^PSJLMUDE(PSGP,PSGORD)
SET VALMBCK="R"
SET PSGSD=PSGNESD
SET PSGFD=PSGNEFD
QUIT
+5 ;
+6 ;
31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1
32 ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]""
33 ;;10^PSGOE81;PSGOSD;PSGSD;10;0
34 ;;3^PSGOE8;PSGOMR;PSGMR;3;1
35 ;;25^PSGOE81;PSGOFD;PSGFD;25;0
36 ;;7^PSGOE8;PSGOST;PSGST;7;0
37 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
38 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1
39 ;;39^PSGOE81;PSGOAT;PSGAT;39;0
310 ;;1^PSGOE82;PSGOPR;PSGPR;1;1
311 ;;8^PSGOE81;PSGOSI;PSGSI;8;0
312 ;;2^PSGOE82;;;2;0
313 ;;40^PSGOE82;;;40;0
+1 ;
AH ;
+1 WRITE !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order. Answer",!,"'NO' to edit this order now. Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."
+2 QUIT
