PSJOE1 ;BIR/CML - UD OE FOR COMBINED OE; Oct 14, 2020@10:48
;;5.0;INPATIENT MEDICATIONS;**2,7,25,30,47,56,64,179,181,252,281,315,338,373,353,327,319,411,399,448**;16 DEC 97;Build 1
;Per VHA Directive 2004-038, this routine should not be modified.
;Reference to ^DICN in ICR #10009
;Reference to ^VALM in ICR #10118
;Reference to ^TMP("PSODAOC",$J) in ICR #6071
;Reference to ^SC in ICR #10040
;
;*353 Haz Meds cleanup var
;
S PC=0 G AD
;
CM ; Ask Clinic - Clinic Medication Order ;*p319
K DIRUT,PSJCLAPP,DIR,X,Y
D FULL^VALM1
W !
S DIR(0)="PO^44:EMZ",DIR("A")="Visit Location"
I $G(P("CLIN")) S DIR("B")=$P(^SC(+P("CLIN"),0),"^"),PSJCLAPP=P("CLIN")
S DIR("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$$ACTLOC^PSJOE1(Y),$$IMOLOC^PSJOE1(Y,$G(PSGP))>-1"
D ^DIR K DIR
I +Y<1 S PSJCM01=-1 Q
S PSJCLAPP=+Y
D SVST Q:$P(PSJCLAPP,"^",2) Q:$G(PSGORQF)
; Ask for Visit Date/Time ;*p319
K %DT
I $G(P("APPT")) S Y=P("APPT") D DD^%DT I Y'="" S %DT("B")=Y
S %DT("A")="Date/Time of Visit: ",%DT="RAE",%DT("B")=$S($G(%DT("B"))'="":%DT("B"),1:"NOW")
D ^%DT I Y<0!($D(DTOUT)) S PSJCM01=-1 Q
S $P(PSJCLAPP,"^",2)=+Y
K %DT
Q
SVST ;get scheduled/new visits ;*p319
N PSJVST,XX,YY,C,DIR,X,Y,X1,X2,APTMIN,APTMAX,STDT,ENDT,PVST,VST
S APTMIN=$$GET1^DIQ(53.46,+PSJCLAPP,8,"I")
S APTMAX=$$GET1^DIQ(53.46,+PSJCLAPP,9,"I")
S X1=DT,X2=$S(APTMIN:-APTMIN,1:-90) D C^%DTC S STDT=X
S X1=DT,X2=$S(APTMAX:APTMAX,1:365) D C^%DTC S ENDT=X
D VST^ORWCV(.PSJVST,$G(PSGP),STDT,ENDT,1)
Q:'$D(PSJVST)
S (XX,C)=0 F S XX=$O(PSJVST(XX)) Q:'XX S YY=PSJVST(XX) I $P($P(YY,"^"),";",3)=+PSJCLAPP D
.S C=C+1,PSJVIS(C)=$P(YY,"^",3)_"^"_$$FMTE^XLFDT($P(YY,"^",2))_"^"_$P(YY,"^",4)_"^"_$P(YY,"^",2)
Q:C<1
S C=C+1,PSJVIS(C)="New Visit"
V1 W !!?4,"Scheduled Clinic Appointment (",$$FMTE^XLFDT(STDT)," thru ",$$FMTE^XLFDT(ENDT),")"
F I=1:1 S XX=$O(PSJVIS(XX)) Q:'XX S YY=PSJVIS(XX) W !,I,". ",$P(YY,"^"),?35,$$FMTE^XLFDT($P(YY,"^",2)),?55,$P(YY,"^",3)
K DIR S DIR(0)="N^1:"_C
S DIR("A")="Select Visit" D ^DIR
I $D(DIRUT) S PSGORQF=1,PSJCM01=-1 Q
Q:Y=C
S VST=Y
I $$FMDIFF^XLFDT($P(PSJVIS(Y),"^",4),DT,1)<0 S PVST=$$PVST() Q:PVST=-1 G:PVST V1
S $P(PSJCLAPP,"^",2)=$P(PSJVIS(VST),"^",4) W !,"Date/Time of Visit: ",$P(PSJVIS(VST),"^",2)
Q
PVST() ;ask about past visit
N DIR
S DIR(0)="Y"
S DIR("A")="You currently have a past date selected for this visit. Do you want to select a current date"
D ^DIR
I $D(DIRUT) S PSGORQF=1,PSJCM01=-1 Q -1
Q Y
;
EN ;
S PC=0
;
AD ; Ask Drug
;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD using this flag to not display drug error.
K PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1,ANQX ;*315
K PSGDRG,PSGDRGN ;*353
N PSJNORD,PSGORQF,PSGSDX,PSGFDX,PSGNEFDO,PSGEDTOI,PSJOCFG,PSGDREQ S PSJOCFG="NEW UD" S PSJNORD=1 I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC,@IOSTBM,IORC
K PSGORQF
I $D(PSJCMO)!$D(PSJCM01),$G(PSJCMF) D CM I $G(PSJCM01)=-1 G DONE ;*p319
D ^PSGOE7
I +$G(PSJCLAPP) S PSJCMF=1 ;p319 Clinic Order - Flag to display
I $G(PSGORQF) S PSJORQF=1 G DONE
S PC=1,PSJORQF=0 I X?1"S."1.E D ^PSGOES G AD
D ^PSGOE4:'$P(PSJSYSP0,"^",12),^PSGOE3:$P(PSJSYSP0,"^",12)
G:$G(PSGOROE1)=1 AD
K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:14" F X=1:1:14 S PSGEFN(X)=""
I $G(PSJCMO)!$G(PSJCM01) S PSGEFN="1:16" F X=15,16 S PSGEFN(X)="" ;p319
S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGPD=PSGPDRG,PSGOINST="",PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
S:$D(PSJOCFG) PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC2^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC2^PSGMI(PSGNEFD) ;#373
S PSGAT=PSGS0Y,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGLI=PSGDT,PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
S PSGSD=PSGNESD,PSGFD=PSGNEFD
K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
I $G(PSJACEPT)=1 D I $G(ANQX) D DONE G AD
. D OC
. ;D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",+$G(PSGDRG))
;If intervention is not log then quit
I $G(PSGORQF)=1 S PSJACEPT=0
S PSJNOO=-1 I $G(PSJACEPT)=1 S PSJNOO=$$ENNOO^PSJUTL5("N")
I $G(PSJNOO)<0 D
. I $$ISCLOZ^PSJCLOZ(,PSGPD) K ^XTMP("PSJ4D-"_$G(DFN)) ;p327
I $G(PSJNOO)<0 K PSJACEPT,PSJCLAPP W !,"No order created." G AD
K PSGOEE D ^PSGOETO S PSJORD=PSGORD
S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
I $G(PSODAND) S ^TMP("PSJCOM",$J,+PSGORD,"SAND")=PSODAND
;RTC 178746 - Don't store allergy here.
;D SETOC^PSJNEWOC(PSGORD)
I PSGOEAV D G AD
.;; START NCC REMEDIATION >> 327*RJS
.I $$ISCLOZ^PSJCLOZ(,PSGPD) D
..N DIE,DA,DR S DIE="^PS(55,"_PSGP_",5,",DA=+$G(PSGORD),DA(1)=PSGP,DR="301////"
..I $G(PSGNTDD) S DR=DR_PSGNTDD
..E I $G(PSGETDD) S DR=DR_PSGETDD
..E I $G(PSGCTDD) S DR=DR_PSGCTDD
..E I $D(^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")) S DR=DR_$G(^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")) K ^TMP($J,"PSGCLOZ",PSGP,+$G(PSGORD),"SAND")
..D ^DIE
..D CLOZSND^PSJOE ; SEND OVERRIDE MESSAGE & XTMP TRANSACTION DATA
.;; END NCC REMEDIATION >> 327*RJS
. D SETOC^PSJNEWOC(PSGORD) ;RTC 17874
.I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
S PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),^PSGOE1,EN^VALM("PSJ LM UD ACTION")
;RTC 178746 - store allergy if not verify the newly created order.
I ($G(PSGORD)["P"),($P($G(^PS(53.1,+PSGORD,0)),U,9)="N"),($G(PSJOCFG)="NEW UD") D SETOC^PSJNEWOC(PSGORD)
G AD
Q
OC ;
NEW PSJDD,PSJALLGY,PSJALGY1
K PSGORQF
;; START NCC REMEDIATION >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD) I CLOZFLG D Q:$G(ANQX)
.S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DIR K DIR I $D(DIRUT) S (CHK,ANQX)=1 Q
.S (PSGNTDD,PSODAND)=X,PSGDN=$P(CLOZFLG,U,2)
;; END NCC REMEDIATION >> 327*RJS
D FULL^VALM1
S PSJDD=+$$DD53P45^PSJMISC() I 'PSJDD S PSGORQF=1 Q
I +$G(PSGEDTOI) D
. S PSJALGY1=1
. D ENDDC^PSGSICHK($G(PSGP),PSJDD)
D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
Q
EDIT(PROMPT) ;
; Edit fields in a UD order.
; PROMPT=0 - Select fields to edit by number.
; PROMPT=1 - Prompt to select fields for editing.
;
;* D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y S PSGOEEG=3 D EDIT^PSGOEE ;$S(PSGOEEWF[53.1:3,1:5) D:Y EDIT^PSGOEE
; PSJ*5.0*448: CORRECTLY SETTING PSGOEEWF
D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y S:$G(PSJNEWOE) PSGOEEWF="^PS(53.1,"_+$G(PSGORD)_"," S PSGOEEG=$S('$D(PSGOEEWF):3,PSGOEEWF[53.1:3,1:5) D EDIT^PSGOEE
I $G(PSJNEWOE) S PSGOEENO=0,DR="",VALMBCK="R"
I '$G(PSJNEWOE) D ENNOU^PSGOEE0 I 'PSGOEENO,DR="" S VALMBCK="R" Q
I 'PSGOEENO,$D(PSGOES) D ENNOU^PSGOEE0 ; only update on order sets
;*179 No longer call CKDT^PSGOEE from here.
;I 'PSGOEENO,$G(PSGPDNX)=1 D CKDT^PSGOEE
I $G(PSGOEER)["101^PSGOE8" S PSGEDTOI=1
K VALMSG I PSGOEENO D
.S VALMSG="This change will cause a new order to be created." D GTSTATUS^PSGOEE,CHKDD^PSGOEE,CKDT^PSGOEE ;*373
.S PSGEBN=$$ENNPN^PSGMI(DUZ),PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGLI=PSGDT
D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
D INIT^PSJLMUDE(PSGP,$G(PSGORD))
Q
DONE ;
K %,DA,DIC,DIE,DR,DRG,DRGN,DRGO,ND,OC,ORIFN,ORIT,ORPK,ORSTOP,ORSTRT,ORSTS,ORTX,PC,PSGDO,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOROE1,PSGORD,PSGS0XT,PSGS0Y,PSGSCH,PSGSI,PSGX,Y,Z
K PSGEDTOI,PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2,ND2P1 ;*315
Q
;
GDO ;
W !!,"Drug is not found in Formulary List." F S %=1 W !,"Would you like to try to search the list again" D YN^DICN Q:% D TAM
Q:%<2
FTD ;
R !!,"Enter FREE TEXT DRUG: ",PSGDRGN:DTIME E W $C(7) S PSGDRGN="^" Q
Q:"^"[PSGDRGN S X=$S(PSGDRGN'?.ANP:"Control character(s)",PSGDRGN["^":"Up-arrow ('^') in text",$L(PSGDRGN)>39:"Response longer than 39 characters",1:"") I X]"" W $C(7)," ??",!?2,"(",X," not allowed.)" G FTD
Q:PSGDRGN'?1."?"
W !!?2,"ENTER DRUG ORDERED (1-39 CHARACTERS).",!?2,"Since the drug cannot be found in the DRUG file, enter the drug name here",!,"exactly as ordered. Press the RETURN key (or enter an '^') to skip over this",!,"drug, or to again search the"
W " DRUG file for this one." G FTD
;
TAM ; Try Again Message
W !!," Enter a 'Y' to try again to find the drug ordered from the Formulary. (The",!,"order cannot become active until a Formulary drug has been entered.) Enter 'N'",!,"to enter the drug ordered as free text for later reference."
W " Enter '^' to exit.",! Q
ACTLOC(LOC) ; Function: returns TRUE if active hospital location; p319
; IA# 10040.
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
Q 1 ; must still be active
;
IMOLOC(LOC,PSGP) ; Is it an IMO location; p319
N PSJY
I $G(LOC)=""!('+$G(PSGP)) Q -1
S PSJY=$$SDIMO^SDAMA203(LOC,PSGP)
I PSJY=-3 D
.I $P($G(^SC(LOC,0)),U,3)'="C" Q
.I $D(^SC("AE",1,LOC))=1 S PSJY=1
.K SDIMO(1)
Q PSJY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOE1 9230 printed Dec 13, 2024@02:08:09 Page 2
PSJOE1 ;BIR/CML - UD OE FOR COMBINED OE; Oct 14, 2020@10:48
+1 ;;5.0;INPATIENT MEDICATIONS;**2,7,25,30,47,56,64,179,181,252,281,315,338,373,353,327,319,411,399,448**;16 DEC 97;Build 1
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Reference to ^DICN in ICR #10009
+4 ;Reference to ^VALM in ICR #10118
+5 ;Reference to ^TMP("PSODAOC",$J) in ICR #6071
+6 ;Reference to ^SC in ICR #10040
+7 ;
+8 ;*353 Haz Meds cleanup var
+9 ;
+10 SET PC=0
GOTO AD
+11 ;
CM ; Ask Clinic - Clinic Medication Order ;*p319
+1 KILL DIRUT,PSJCLAPP,DIR,X,Y
+2 DO FULL^VALM1
+3 WRITE !
+4 SET DIR(0)="PO^44:EMZ"
SET DIR("A")="Visit Location"
+5 IF $GET(P("CLIN"))
SET DIR("B")=$PIECE(^SC(+P("CLIN"),0),"^")
SET PSJCLAPP=P("CLIN")
+6 SET DIR("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$$ACTLOC^PSJOE1(Y),$$IMOLOC^PSJOE1(Y,$G(PSGP))>-1"
+7 DO ^DIR
KILL DIR
+8 IF +Y<1
SET PSJCM01=-1
QUIT
+9 SET PSJCLAPP=+Y
+10 DO SVST
if $PIECE(PSJCLAPP,"^",2)
QUIT
if $GET(PSGORQF)
QUIT
+11 ; Ask for Visit Date/Time ;*p319
+12 KILL %DT
+13 IF $GET(P("APPT"))
SET Y=P("APPT")
DO DD^%DT
IF Y'=""
SET %DT("B")=Y
+14 SET %DT("A")="Date/Time of Visit: "
SET %DT="RAE"
SET %DT("B")=$SELECT($GET(%DT("B"))'="":%DT("B"),1:"NOW")
+15 DO ^%DT
IF Y<0!($DATA(DTOUT))
SET PSJCM01=-1
QUIT
+16 SET $PIECE(PSJCLAPP,"^",2)=+Y
+17 KILL %DT
+18 QUIT
SVST ;get scheduled/new visits ;*p319
+1 NEW PSJVST,XX,YY,C,DIR,X,Y,X1,X2,APTMIN,APTMAX,STDT,ENDT,PVST,VST
+2 SET APTMIN=$$GET1^DIQ(53.46,+PSJCLAPP,8,"I")
+3 SET APTMAX=$$GET1^DIQ(53.46,+PSJCLAPP,9,"I")
+4 SET X1=DT
SET X2=$SELECT(APTMIN:-APTMIN,1:-90)
DO C^%DTC
SET STDT=X
+5 SET X1=DT
SET X2=$SELECT(APTMAX:APTMAX,1:365)
DO C^%DTC
SET ENDT=X
+6 DO VST^ORWCV(.PSJVST,$GET(PSGP),STDT,ENDT,1)
+7 if '$DATA(PSJVST)
QUIT
+8 SET (XX,C)=0
FOR
SET XX=$ORDER(PSJVST(XX))
if 'XX
QUIT
SET YY=PSJVST(XX)
IF $PIECE($PIECE(YY,"^"),";",3)=+PSJCLAPP
Begin DoDot:1
+9 SET C=C+1
SET PSJVIS(C)=$PIECE(YY,"^",3)_"^"_$$FMTE^XLFDT($PIECE(YY,"^",2))_"^"_$PIECE(YY,"^",4)_"^"_$PIECE(YY,"^",2)
End DoDot:1
+10 if C<1
QUIT
+11 SET C=C+1
SET PSJVIS(C)="New Visit"
V1 WRITE !!?4,"Scheduled Clinic Appointment (",$$FMTE^XLFDT(STDT)," thru ",$$FMTE^XLFDT(ENDT),")"
+1 FOR I=1:1
SET XX=$ORDER(PSJVIS(XX))
if 'XX
QUIT
SET YY=PSJVIS(XX)
WRITE !,I,". ",$PIECE(YY,"^"),?35,$$FMTE^XLFDT($PIECE(YY,"^",2)),?55,$PIECE(YY,"^",3)
+2 KILL DIR
SET DIR(0)="N^1:"_C
+3 SET DIR("A")="Select Visit"
DO ^DIR
+4 IF $DATA(DIRUT)
SET PSGORQF=1
SET PSJCM01=-1
QUIT
+5 if Y=C
QUIT
+6 SET VST=Y
+7 IF $$FMDIFF^XLFDT($PIECE(PSJVIS(Y),"^",4),DT,1)<0
SET PVST=$$PVST()
if PVST=-1
QUIT
if PVST
GOTO V1
+8 SET $PIECE(PSJCLAPP,"^",2)=$PIECE(PSJVIS(VST),"^",4)
WRITE !,"Date/Time of Visit: ",$PIECE(PSJVIS(VST),"^",2)
+9 QUIT
PVST() ;ask about past visit
+1 NEW DIR
+2 SET DIR(0)="Y"
+3 SET DIR("A")="You currently have a past date selected for this visit. Do you want to select a current date"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET PSGORQF=1
SET PSJCM01=-1
QUIT -1
+6 QUIT Y
+7 ;
EN ;
+1 SET PC=0
+2 ;
AD ; Ask Drug
+1 ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD using this flag to not display drug error.
+2 ;*315
KILL PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1,ANQX
+3 ;*353
KILL PSGDRG,PSGDRGN
+4 NEW PSJNORD,PSGORQF,PSGSDX,PSGFDX,PSGNEFDO,PSGEDTOI,PSJOCFG,PSGDREQ
SET PSJOCFG="NEW UD"
SET PSJNORD=1
IF $DATA(VALM("TM"))
SET IOTM=VALM("TM")
SET IOBM=IOSL
WRITE IOSC,@IOSTBM,IORC
+5 KILL PSGORQF
+6 ;*p319
IF $DATA(PSJCMO)!$DATA(PSJCM01)
IF $GET(PSJCMF)
DO CM
IF $GET(PSJCM01)=-1
GOTO DONE
+7 DO ^PSGOE7
+8 ;p319 Clinic Order - Flag to display
IF +$GET(PSJCLAPP)
SET PSJCMF=1
+9 IF $GET(PSGORQF)
SET PSJORQF=1
GOTO DONE
+10 SET PC=1
SET PSJORQF=0
IF X?1"S."1.E
DO ^PSGOES
GOTO AD
+11 if '$PIECE(PSJSYSP0,"^",12)
DO ^PSGOE4
if $PIECE(PSJSYSP0,"^",12)
DO ^PSGOE3
+12 if $GET(PSGOROE1)=1
GOTO AD
+13 KILL PSGEFN,PSGOEEF,PSGOEE,PSGOEOS
SET PSGEFN="1:14"
FOR X=1:1:14
SET PSGEFN(X)=""
+14 ;p319
IF $GET(PSJCMO)!$GET(PSJCM01)
SET PSGEFN="1:16"
FOR X=15,16
SET PSGEFN(X)=""
+15 SET PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG)
SET PSGPD=PSGPDRG
SET PSGOINST=""
SET PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD)
SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
+16 ;#373
if $DATA(PSJOCFG)
SET PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC2^PSGMI(PSGNESD)
SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC2^PSGMI(PSGNEFD)
+17 SET PSGAT=PSGS0Y
SET PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT)
SET PSGLI=PSGDT
SET PSGEBN=$$ENNPN^PSGMI(DUZ)
SET PSGSTAT=$SELECT(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
+18 DO CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
+19 SET PSGSD=PSGNESD
SET PSGFD=PSGNEFD
+20 KILL PSJACEPT
SET VALMBCK="Q"
if $DATA(Y)
DO EN^VALM("PSJU LM ACCEPT")
+21 IF $GET(PSJACEPT)=1
Begin DoDot:1
+22 DO OC
+23 ;D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",+$G(PSGDRG))
End DoDot:1
IF $GET(ANQX)
DO DONE
GOTO AD
+24 ;If intervention is not log then quit
+25 IF $GET(PSGORQF)=1
SET PSJACEPT=0
+26 SET PSJNOO=-1
IF $GET(PSJACEPT)=1
SET PSJNOO=$$ENNOO^PSJUTL5("N")
+27 IF $GET(PSJNOO)<0
Begin DoDot:1
+28 ;p327
IF $$ISCLOZ^PSJCLOZ(,PSGPD)
KILL ^XTMP("PSJ4D-"_$GET(DFN))
End DoDot:1
+29 IF $GET(PSJNOO)<0
KILL PSJACEPT,PSJCLAPP
WRITE !,"No order created."
GOTO AD
+30 KILL PSGOEE
DO ^PSGOETO
SET PSJORD=PSGORD
+31 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSGORD
+32 IF $GET(PSODAND)
SET ^TMP("PSJCOM",$JOB,+PSGORD,"SAND")=PSODAND
+33 ;RTC 178746 - Don't store allergy here.
+34 ;D SETOC^PSJNEWOC(PSGORD)
+35 IF PSGOEAV
Begin DoDot:1
+36 ;; START NCC REMEDIATION >> 327*RJS
+37 IF $$ISCLOZ^PSJCLOZ(,PSGPD)
Begin DoDot:2
+38 NEW DIE,DA,DR
SET DIE="^PS(55,"_PSGP_",5,"
SET DA=+$GET(PSGORD)
SET DA(1)=PSGP
SET DR="301////"
+39 IF $GET(PSGNTDD)
SET DR=DR_PSGNTDD
+40 IF '$TEST
IF $GET(PSGETDD)
SET DR=DR_PSGETDD
+41 IF '$TEST
IF $GET(PSGCTDD)
SET DR=DR_PSGCTDD
+42 IF '$TEST
IF $DATA(^TMP($JOB,"PSGCLOZ",PSGP,+$GET(PSGORD),"SAND"))
SET DR=DR_$GET(^TMP($JOB,"PSGCLOZ",PSGP,+$GET(PSGORD),"SAND"))
KILL ^TMP($JOB,"PSGCLOZ",PSGP,+$GET(PSGORD),"SAND")
+43 DO ^DIE
+44 ; SEND OVERRIDE MESSAGE & XTMP TRANSACTION DATA
DO CLOZSND^PSJOE
End DoDot:2
+45 ;; END NCC REMEDIATION >> 327*RJS
+46 ;RTC 17874
DO SETOC^PSJNEWOC(PSGORD)
+47 IF '$DATA(PSGOEE)
IF +PSJSYSU=3
DO EN^PSGPEN(PSGORD)
End DoDot:1
GOTO AD
+48 SET PSGOEEF=0
DO GETUD^PSJLMGUD(PSGP,PSGORD)
DO ENSFE^PSGOEE0(PSGP,PSGORD)
DO ^PSGOE1
DO EN^VALM("PSJ LM UD ACTION")
+49 ;RTC 178746 - store allergy if not verify the newly created order.
+50 IF ($GET(PSGORD)["P")
IF ($PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)="N")
IF ($GET(PSJOCFG)="NEW UD")
DO SETOC^PSJNEWOC(PSGORD)
+51 GOTO AD
+52 QUIT
OC ;
+1 NEW PSJDD,PSJALLGY,PSJALGY1
+2 KILL PSGORQF
+3 ;; START NCC REMEDIATION >> 327*RJS
+4 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD)
IF CLOZFLG
Begin DoDot:1
+5 SET DIR(0)="N^12.5:3000:1"
SET DIR("A")="CLOZAPINE dosage (mg/day) ? "
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET (CHK,ANQX)=1
QUIT
+6 SET (PSGNTDD,PSODAND)=X
SET PSGDN=$PIECE(CLOZFLG,U,2)
End DoDot:1
if $GET(ANQX)
QUIT
+7 ;; END NCC REMEDIATION >> 327*RJS
+8 DO FULL^VALM1
+9 SET PSJDD=+$$DD53P45^PSJMISC()
IF 'PSJDD
SET PSGORQF=1
QUIT
+10 IF +$GET(PSGEDTOI)
Begin DoDot:1
+11 SET PSJALGY1=1
+12 DO ENDDC^PSGSICHK($GET(PSGP),PSJDD)
End DoDot:1
+13 if '$GET(PSGORQF)
DO IN^PSJOCDS($GET(PSGORD),"UD",PSJDD)
+14 QUIT
EDIT(PROMPT) ;
+1 ; Edit fields in a UD order.
+2 ; PROMPT=0 - Select fields to edit by number.
+3 ; PROMPT=1 - Prompt to select fields for editing.
+4 ;
+5 ;* D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y S PSGOEEG=3 D EDIT^PSGOEE ;$S(PSGOEEWF[53.1:3,1:5) D:Y EDIT^PSGOEE
+6 ; PSJ*5.0*448: CORRECTLY SETTING PSGOEEWF
+7 DO @$SELECT('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON")
if 'Y
QUIT
if $GET(PSJNEWOE)
SET PSGOEEWF="^PS(53.1,"_+$GET(PSGORD)_","
SET PSGOEEG=$SELECT('$DATA(PSGOEEWF):3,PSGOEEWF[53.1:3,1:5)
DO EDIT^PSGOEE
+8 IF $GET(PSJNEWOE)
SET PSGOEENO=0
SET DR=""
SET VALMBCK="R"
+9 IF '$GET(PSJNEWOE)
DO ENNOU^PSGOEE0
IF 'PSGOEENO
IF DR=""
SET VALMBCK="R"
QUIT
+10 ; only update on order sets
IF 'PSGOEENO
IF $DATA(PSGOES)
DO ENNOU^PSGOEE0
+11 ;*179 No longer call CKDT^PSGOEE from here.
+12 ;I 'PSGOEENO,$G(PSGPDNX)=1 D CKDT^PSGOEE
+13 IF $GET(PSGOEER)["101^PSGOE8"
SET PSGEDTOI=1
+14 KILL VALMSG
IF PSGOEENO
Begin DoDot:1
+15 ;*373
SET VALMSG="This change will cause a new order to be created."
DO GTSTATUS^PSGOEE
DO CHKDD^PSGOEE
DO CKDT^PSGOEE
+16 SET PSGEBN=$$ENNPN^PSGMI(DUZ)
SET PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT)
SET PSGLI=PSGDT
End DoDot:1
+17 DO CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
+18 DO INIT^PSJLMUDE(PSGP,$GET(PSGORD))
+19 QUIT
DONE ;
+1 KILL %,DA,DIC,DIE,DR,DRG,DRGN,DRGO,ND,OC,ORIFN,ORIT,ORPK,ORSTOP,ORSTRT,ORSTS,ORTX,PC,PSGDO,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOROE1,PSGORD,PSGS0XT,PSGS0Y,PSGSCH,PSGSI,PSGX,Y,Z
+2 ;*315
KILL PSGEDTOI,PSJOCFG,PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2,ND2P1
+3 QUIT
+4 ;
GDO ;
+1 WRITE !!,"Drug is not found in Formulary List."
FOR
SET %=1
WRITE !,"Would you like to try to search the list again"
DO YN^DICN
if %
QUIT
DO TAM
+2 if %<2
QUIT
FTD ;
+1 READ !!,"Enter FREE TEXT DRUG: ",PSGDRGN:DTIME
IF '$TEST
WRITE $CHAR(7)
SET PSGDRGN="^"
QUIT
+2 if "^"[PSGDRGN
QUIT
SET X=$SELECT(PSGDRGN'?.ANP:"Control character(s)",PSGDRGN["^":"Up-arrow ('^') in text",$LENGTH(PSGDRGN)>39:"Response longer than 39 characters",1:"")
IF X]""
WRITE $CHAR(7)," ??",!?2,"(",X," not allowed.)"
GOTO FTD
+3 if PSGDRGN'?1."?"
QUIT
+4 WRITE !!?2,"ENTER DRUG ORDERED (1-39 CHARACTERS).",!?2,"Since the drug cannot be found in the DRUG file, enter the drug name here",!,"exactly as ordered. Press the RETURN key (or enter an '^') to skip over this",!,"drug, or to again search the
"
+5 WRITE " DRUG file for this one."
GOTO FTD
+6 ;
TAM ; Try Again Message
+1 WRITE !!," Enter a 'Y' to try again to find the drug ordered from the Formulary. (The",!,"order cannot become active until a Formulary drug has been entered.) Enter 'N'",!,"to enter the drug ordered as free text for later reference."
+2 WRITE " Enter '^' to exit.",!
QUIT
ACTLOC(LOC) ; Function: returns TRUE if active hospital location; p319
+1 ; IA# 10040.
+2 ; screen out OOS entry
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+3 ; chk out of svc wards
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+4 ; no inactivate date
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+5 ; chk reactivate date
IF DT>$PIECE(X,U)&($PIECE(X,U,2)=""!(DT<$PIECE(X,U,2)))
QUIT 0
+6 ; must still be active
QUIT 1
+7 ;
IMOLOC(LOC,PSGP) ; Is it an IMO location; p319
+1 NEW PSJY
+2 IF $GET(LOC)=""!('+$GET(PSGP))
QUIT -1
+3 SET PSJY=$$SDIMO^SDAMA203(LOC,PSGP)
+4 IF PSJY=-3
Begin DoDot:1
+5 IF $PIECE($GET(^SC(LOC,0)),U,3)'="C"
QUIT
+6 IF $DATA(^SC("AE",1,LOC))=1
SET PSJY=1
+7 KILL SDIMO(1)
End DoDot:1
+8 QUIT PSJY
