Routine: PSGOEF

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)=""

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

BYPASS ;

 S PSGCANFL=1

DONE ;

 K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT,PSGEDTOI,PSGOEER,ZZND

 K PSJOVR

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."

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEF   15478     printed  Mar 13, 2025@21:07:03                                                                                                                                                                                                     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

PSGOEF.m