PSGOE1 ;BIR/CML3-ACTION ON INPATIENT ORDERS ;Jul 22, 2020@10:37:11
;;5.0;INPATIENT MEDICATIONS;**7,19,26,39,58,85,80,110,127,133,134,315,366,385,319**;16 DEC 97;Build 31
;
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PSDRUG( is supported by DBIA #2192.
; Reference to EN1^ORCFLAG is supported by DBIA #3620.
; Reference to AND^ORX8 is supported by DBIA #3632.
EN ;
K PSGDFLG,PSGPFLG S PSGOEA="^",PSGACT="",(PSGDI,PSGOENG,PSGPI,PSGRRF)=0
Q:'$G(DUZ)
D @$S(PSGORD["P":"NON",1:"ACT")
GO ;
K A,ND,PSGE,PSGR,ST,X,X1,X2,Y I $D(ORACTION) K PSGDI,PSGOENG,PSGPI Q
Q
ENACTION(PSGP,PSGORD) ;
;Returns string identifying the actions allowed on this order.
D EN
Q PSGACT
DONE ;
I PSGORD["U"!(PSGORD["O") L -^PS(55,PSGP,5,+PSGORD)
E L -^PS(53.1,+PSGORD)
K C,PSGACT,PSGDFLG,PSGPFLG,PSGDI,PSGOENG,PSGPI,PSGRRF Q
B ; bypass
S PSGCANFL=1
Q
C ; copy an order (does NOT discontinue original order)
D ^PSGOD Q
D ; discontinue (or delete) an order
I PSGOEAV,'$D(PSGODF) D ENDS^PSGPO Q
D ENO^PSGOEC(PSGP,PSGORD) Q
E ; edit orders
D ^PSGOEE Q
F ; finish released orders
D ^PSGOEF Q
H(PSGP,PSGORD) ; hold
S X=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(X,U,12),$P(X,U,13) W $C(7),!!,"WARNING! THIS ORDER HAS BEEN MARKED FOR CANCELLATION."
I $P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9)="H" D ^PSGOEH0 Q
D ^PSGOEH1 Q
I ; mark (or unmark) a non-verified order as 'incomplete'
D ^PSGOEI Q
L ; display logs
D ^PSGOEL Q
N ; mark order as 'not to be given'
D ^PSGOENG Q
O ; Outpatient (discharge) med
W !!,"UNDER DEVELOPMENT, NOT CURRENTLY AVAILABLE."
Q
P ; print expanded view
D ^PSGVWP Q
R ; renew an order
I 'PSJSYSU,$D(^PS(55,PSGP,5,+PSGORD,4)),$P(^(4),"^",15),$P(^(4),"^",16) W !!,"THIS ORDER IS ALREADY MARKED FOR RENEWAL!" Q
I 'PSGRRF D ^PSGOER Q
D ^PSGOERI Q
S ; show the order again
D EN2^PSGVW Q
V ; verify an order
D EN^PSGOEV Q
ACT ;
S X=$G(^PS(55,PSGP,5,+PSGORD,0)),ND0=X,ND=$G(^(4)),ND2=$G(^(2)),ND2P1=$G(^(2.1)),PSGOENG=$P(X,"^",22),PSGR=$E("R",'PSGOENG),PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8) ;*315
I 'PSGOENG,PSJCOM S PSGR=$E("R",$$AND^ORX8(PSJCOM)) S:PSGR="R" PSGR=$E("R",$$RNEWOK^PSJUTL2(PSJCOM,PSGP))
S PSGR=$E("R",'$$EXPIRED^PSGOER(PSGP,PSGORD)) S PSGR=$E("R",$P(ND0,"^",7)'="O")
I $P(ND2,U,4)'>PSGDT D OLD Q
S PSGE="E" I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$G(^PS(55,PSGP,5,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(55,PSGP,5,+PSGORD,.2)))
S:$P(X,"^",26) (PSGE,PSGR)=""
;*366 - check provider credentials
I '$D(PSGOETOF) S PSGPI=$P(X,"^",2) I PSGPI S PSGPI='$$ACTPRO^PSGOE1(PSGPI)
S ST=$P(X,"^",9)="H"*4 S:ST (PSGE,PSGR)=""
N CMPOK S CMPOK=1 I $$COMPLEX^PSJOE(PSGP,PSGORD) S CMPOK=+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8)
S PSGACT="D"_$S('$G(CMPOK):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR)
I PSJSYSU,'$P(ND,"^",+PSJSYSU) S PSGACT=PSGACT_"V"
I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
Q
OLD ;
S A=$P(ND0,"^",9),PSGACT=$E("H",A="H")_"L" I A'["D",A'["E" Q
I 'PSGOENG,($D(^XUSEC("PSJU MGR",DUZ))!$D(^XUSEC("PSJ RPHARM",DUZ))) S PSGACT="LN"
I PSJSYSU,'$P(ND,"^",+PSJSYSU) S:(A'["D")&($G(PSGPRIO)'="DONE") PSGACT="D"_PSGACT S PSGACT=PSGACT_"V" Q
Q:PSGR=""!'PSJPCAF D NOW^%DTC S (PSGDT,X1)=+$E(%,1,12),X2=-4 D C^%DTC I $S('$P(ND2,"^",4):1,1:$P(ND2,"^",4)'>X) Q
I A="E",$G(PSJPRI)'="D" S PSGACT=PSGACT_PSGR Q
I PSJSYSU,$P(ND,"^",11) S PSGACT=PSGACT_PSGR,PSGRRF=1
Q
NON ;
N XND,DRGPT,XND2
S (X,XND)=$G(^PS(53.1,+PSGORD,0)) I $P(X,"^",19),$D(^PS(55,PSGP,5,$P(X,"^",19))) L -^PS(53.1,+PSGORD) S PSGORD=$P(X,"^",19)_"U" G ACT
I $S($P(X,"^",26):1,$P(X,"^",9)["D":1,1:$P(X,"^",9)["E") S:$P(X,U,9)="P"&($P(X,U,26)) PSGACT="D" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
I PSGORD["U" S PSGACT="DE" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$G(^PS(53.1,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(53.1,+PSGORD,.2)))
S DRG=$$STUFFDD^PSGOE2 S:DRG ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1",^PS(53.1,+PSGORD,1,1,0)=DRG,^PS(53.1,+PSGORD,1,"B",DRG,1)=""
F DRG=0:0 S DRG=$O(^PS(53.1,+PSGORD,1,DRG)) Q:'DRG S DRGPT=^(DRG,0) S INACTDT=$G(^PSDRUG(+DRGPT,"I")) I INACTDT,(INACTDT'>DT) S PSGDFLG=1
I $P(XND,U,9)="P" S PSGACT=$S(+PSJSYSU=3:"BDEF",$G(PSJRNF):"BDEF",1:"") S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
;*366 - check provider credentials
I '$D(PSGOETOF) S PSGPI=$P(XND,"^",2) I PSGPI S PSGPI='$$ACTPRO^PSGOE1(PSGPI)
S PSGACT="DEI" I PSJSYSU,'PSGPI,$P(XND,"^",9)'="I",$$FNP(+PSGORD) S PSGACT=PSGACT_"V"
S XND2=$G(^PS(53.1,+PSGORD,.2)) I $P(XND2,"^",8),$P(XND,"^",9)="P" S PSGACT=$TR(PSGACT,"V")
I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
I $P($G(PSGRDTX),U,2)]"",'$P($G(^PS(53.1,+PSGORD,2.5)),"^",2) S $P(^PS(53.1,+PSGORD,2.5),U,2)=$P(PSGRDTX,U,2)
Q
;
FNP(PSGDA) ;*319 - check if order finished by a pharmacist, when user is a nurse
N IEN,VAL,ND
S VAL=1
I (+PSJSYSU'=1)!($P($G(^PS(53.1,+PSGDA,0)),"^",9)'="N") Q VAL
S IEN=0 F S IEN=$O(^PS(53.1,+PSGDA,"A",IEN)) Q:'IEN S ND=$G(^(IEN,0)) I $P($G(^PS(53.3,+$P(ND,"^",3),0)),"^",2)="FP" S VAL=0 Q
Q VAL
;
ACTO ;
S PSGACTO="" I $G(PSGACT)]"" F X=1:1:$L(PSGACT) S PSGACTO=PSGACTO_$S($E(PSGACT,X)="D":"DC",1:$E(PSGACT,X))_" "
S:PSGACTO]"" PSGACTO=$E(PSGACTO,1,$L(PSGACTO)-1) Q
;
ACTPRO(PSJDA) ;*366 - check provider credentials
N %,X1,X2
Q:'$D(PSJDA) ""
S PSJDA=+PSJDA
Q:'$G(PSJDA) ""
;check for zero node
Q:'$D(^VA(200,PSJDA,0)) ""
S X1=$G(^VA(200,PSJDA,0))
;check for DISUSER
Q:$P(X1,U,7)=1 "0^DISUSER"
;check for provider key
Q:'$D(^XUSEC("PROVIDER",PSJDA))&'$D(^XUSEC("ORELSE",PSJDA)) "0^NO PROVIDER KEY"
;check termination date is <today's date
S %=+$P(X1,U,11) I %>0,%<DT Q "0^TERMINATED^"_%
;check inactivation date is <today's date
S X2=$G(^VA(200,PSJDA,"PS"))
Q:X2=""!('X2) "0^NOT AUTHORIZED TO WRITE"
S %=+$P(X2,U,4) I %>0,%<DT Q "0^INACTIVATED^"_%
;Default:
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE1 6152 printed Sep 23, 2025@19:37:55 Page 2
PSGOE1 ;BIR/CML3-ACTION ON INPATIENT ORDERS ;Jul 22, 2020@10:37:11
+1 ;;5.0;INPATIENT MEDICATIONS;**7,19,26,39,58,85,80,110,127,133,134,315,366,385,319**;16 DEC 97;Build 31
+2 ;
+3 ;;Per VHA Directive 2004-038, this routine should not be modified.
+4 ; Reference to ^PS(55 is supported by DBIA #2191.
+5 ; Reference to ^PSDRUG( is supported by DBIA #2192.
+6 ; Reference to EN1^ORCFLAG is supported by DBIA #3620.
+7 ; Reference to AND^ORX8 is supported by DBIA #3632.
EN ;
+1 KILL PSGDFLG,PSGPFLG
SET PSGOEA="^"
SET PSGACT=""
SET (PSGDI,PSGOENG,PSGPI,PSGRRF)=0
+2 if '$GET(DUZ)
QUIT
+3 DO @$SELECT(PSGORD["P":"NON",1:"ACT")
GO ;
+1 KILL A,ND,PSGE,PSGR,ST,X,X1,X2,Y
IF $DATA(ORACTION)
KILL PSGDI,PSGOENG,PSGPI
QUIT
+2 QUIT
ENACTION(PSGP,PSGORD) ;
+1 ;Returns string identifying the actions allowed on this order.
+2 DO EN
+3 QUIT PSGACT
DONE ;
+1 IF PSGORD["U"!(PSGORD["O")
LOCK -^PS(55,PSGP,5,+PSGORD)
+2 IF '$TEST
LOCK -^PS(53.1,+PSGORD)
+3 KILL C,PSGACT,PSGDFLG,PSGPFLG,PSGDI,PSGOENG,PSGPI,PSGRRF
QUIT
B ; bypass
+1 SET PSGCANFL=1
+2 QUIT
C ; copy an order (does NOT discontinue original order)
+1 DO ^PSGOD
QUIT
D ; discontinue (or delete) an order
+1 IF PSGOEAV
IF '$DATA(PSGODF)
DO ENDS^PSGPO
QUIT
+2 DO ENO^PSGOEC(PSGP,PSGORD)
QUIT
E ; edit orders
+1 DO ^PSGOEE
QUIT
F ; finish released orders
+1 DO ^PSGOEF
QUIT
H(PSGP,PSGORD) ; hold
+1 SET X=$GET(^PS(55,PSGP,5,+PSGORD,4))
IF $PIECE(X,U,12)
IF $PIECE(X,U,13)
WRITE $CHAR(7),!!,"WARNING! THIS ORDER HAS BEEN MARKED FOR CANCELLATION."
+2 IF $PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",9)="H"
DO ^PSGOEH0
QUIT
+3 DO ^PSGOEH1
QUIT
I ; mark (or unmark) a non-verified order as 'incomplete'
+1 DO ^PSGOEI
QUIT
L ; display logs
+1 DO ^PSGOEL
QUIT
N ; mark order as 'not to be given'
+1 DO ^PSGOENG
QUIT
O ; Outpatient (discharge) med
+1 WRITE !!,"UNDER DEVELOPMENT, NOT CURRENTLY AVAILABLE."
+2 QUIT
P ; print expanded view
+1 DO ^PSGVWP
QUIT
R ; renew an order
+1 IF 'PSJSYSU
IF $DATA(^PS(55,PSGP,5,+PSGORD,4))
IF $PIECE(^(4),"^",15)
IF $PIECE(^(4),"^",16)
WRITE !!,"THIS ORDER IS ALREADY MARKED FOR RENEWAL!"
QUIT
+2 IF 'PSGRRF
DO ^PSGOER
QUIT
+3 DO ^PSGOERI
QUIT
S ; show the order again
+1 DO EN2^PSGVW
QUIT
V ; verify an order
+1 DO EN^PSGOEV
QUIT
ACT ;
+1 ;*315
SET X=$GET(^PS(55,PSGP,5,+PSGORD,0))
SET ND0=X
SET ND=$GET(^(4))
SET ND2=$GET(^(2))
SET ND2P1=$GET(^(2.1))
SET PSGOENG=$PIECE(X,"^",22)
SET PSGR=$EXTRACT("R",'PSGOENG)
SET PSJCOM=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),U,8)
+2 IF 'PSGOENG
IF PSJCOM
SET PSGR=$EXTRACT("R",$$AND^ORX8(PSJCOM))
if PSGR="R"
SET PSGR=$EXTRACT("R",$$RNEWOK^PSJUTL2(PSJCOM,PSGP))
+3 SET PSGR=$EXTRACT("R",'$$EXPIRED^PSGOER(PSGP,PSGORD))
SET PSGR=$EXTRACT("R",$PIECE(ND0,"^",7)'="O")
+4 IF $PIECE(ND2,U,4)'>PSGDT
DO OLD
QUIT
+5 SET PSGE="E"
IF '$DATA(PSGOETOF)
SET (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$GET(^PS(55,PSGP,5,+PSGORD,.2)))
SET PSGPFLG='$$OIOK^PSGOE2(+$GET(^PS(55,PSGP,5,+PSGORD,.2)))
+6 if $PIECE(X,"^",26)
SET (PSGE,PSGR)=""
+7 ;*366 - check provider credentials
+8 IF '$DATA(PSGOETOF)
SET PSGPI=$PIECE(X,"^",2)
IF PSGPI
SET PSGPI='$$ACTPRO^PSGOE1(PSGPI)
+9 SET ST=$PIECE(X,"^",9)="H"*4
if ST
SET (PSGE,PSGR)=""
+10 NEW CMPOK
SET CMPOK=1
IF $$COMPLEX^PSJOE(PSGP,PSGORD)
SET CMPOK=+$PIECE(^PS(55,PSGP,5,+PSGORD,.2),"^",8)
+11 SET PSGACT="D"_$SELECT('$GET(CMPOK):"",1:PSGE)_$SELECT($PIECE(ND,"^",18+ST)&'$PIECE(ND,"^",19+ST)&'$PIECE(ND,"^",PSJSYSU):"",1:"H")_"L"_$SELECT(ST:"",1:PSGR)
+12 IF PSJSYSU
IF '$PIECE(ND,"^",+PSJSYSU)
SET PSGACT=PSGACT_"V"
+13 IF +PSJSYSU=3
IF $LENGTH($TEXT(EN1^ORCFLAG))
SET PSGACT=PSGACT_"G"
+14 QUIT
OLD ;
+1 SET A=$PIECE(ND0,"^",9)
SET PSGACT=$EXTRACT("H",A="H")_"L"
IF A'["D"
IF A'["E"
QUIT
+2 IF 'PSGOENG
IF ($DATA(^XUSEC("PSJU MGR",DUZ))!$DATA(^XUSEC("PSJ RPHARM",DUZ)))
SET PSGACT="LN"
+3 IF PSJSYSU
IF '$PIECE(ND,"^",+PSJSYSU)
if (A'["D")&($GET(PSGPRIO)'="DONE")
SET PSGACT="D"_PSGACT
SET PSGACT=PSGACT_"V"
QUIT
+4 if PSGR=""!'PSJPCAF
QUIT
DO NOW^%DTC
SET (PSGDT,X1)=+$EXTRACT(%,1,12)
SET X2=-4
DO C^%DTC
IF $SELECT('$PIECE(ND2,"^",4):1,1:$PIECE(ND2,"^",4)'>X)
QUIT
+5 IF A="E"
IF $GET(PSJPRI)'="D"
SET PSGACT=PSGACT_PSGR
QUIT
+6 IF PSJSYSU
IF $PIECE(ND,"^",11)
SET PSGACT=PSGACT_PSGR
SET PSGRRF=1
+7 QUIT
NON ;
+1 NEW XND,DRGPT,XND2
+2 SET (X,XND)=$GET(^PS(53.1,+PSGORD,0))
IF $PIECE(X,"^",19)
IF $DATA(^PS(55,PSGP,5,$PIECE(X,"^",19)))
LOCK -^PS(53.1,+PSGORD)
SET PSGORD=$PIECE(X,"^",19)_"U"
GOTO ACT
+3 IF $SELECT($PIECE(X,"^",26):1,$PIECE(X,"^",9)["D":1,1:$PIECE(X,"^",9)["E")
if $PIECE(X,U,9)="P"&($PIECE(X,U,26))
SET PSGACT="D"
if (+PSJSYSU=3)&($LENGTH($TEXT(EN1^ORCFLAG)))
SET PSGACT=PSGACT_"G"
QUIT
+4 IF PSGORD["U"
SET PSGACT="DE"
if (+PSJSYSU=3)&($LENGTH($TEXT(EN1^ORCFLAG)))
SET PSGACT=PSGACT_"G"
QUIT
+5 IF '$DATA(PSGOETOF)
SET (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$GET(^PS(53.1,+PSGORD,.2)))
SET PSGPFLG='$$OIOK^PSGOE2(+$GET(^PS(53.1,+PSGORD,.2)))
+6 SET DRG=$$STUFFDD^PSGOE2
if DRG
SET ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1"
SET ^PS(53.1,+PSGORD,1,1,0)=DRG
SET ^PS(53.1,+PSGORD,1,"B",DRG,1)=""
+7 FOR DRG=0:0
SET DRG=$ORDER(^PS(53.1,+PSGORD,1,DRG))
if 'DRG
QUIT
SET DRGPT=^(DRG,0)
SET INACTDT=$GET(^PSDRUG(+DRGPT,"I"))
IF INACTDT
IF (INACTDT'>DT)
SET PSGDFLG=1
+8 IF $PIECE(XND,U,9)="P"
SET PSGACT=$SELECT(+PSJSYSU=3:"BDEF",$GET(PSJRNF):"BDEF",1:"")
if (+PSJSYSU=3)&($LENGTH($TEXT(EN1^ORCFLAG)))
SET PSGACT=PSGACT_"G"
QUIT
+9 ;*366 - check provider credentials
+10 IF '$DATA(PSGOETOF)
SET PSGPI=$PIECE(XND,"^",2)
IF PSGPI
SET PSGPI='$$ACTPRO^PSGOE1(PSGPI)
+11 SET PSGACT="DEI"
IF PSJSYSU
IF 'PSGPI
IF $PIECE(XND,"^",9)'="I"
IF $$FNP(+PSGORD)
SET PSGACT=PSGACT_"V"
+12 SET XND2=$GET(^PS(53.1,+PSGORD,.2))
IF $PIECE(XND2,"^",8)
IF $PIECE(XND,"^",9)="P"
SET PSGACT=$TRANSLATE(PSGACT,"V")
+13 IF +PSJSYSU=3
IF $LENGTH($TEXT(EN1^ORCFLAG))
SET PSGACT=PSGACT_"G"
+14 IF $PIECE($GET(PSGRDTX),U,2)]""
IF '$PIECE($GET(^PS(53.1,+PSGORD,2.5)),"^",2)
SET $PIECE(^PS(53.1,+PSGORD,2.5),U,2)=$PIECE(PSGRDTX,U,2)
+15 QUIT
+16 ;
FNP(PSGDA) ;*319 - check if order finished by a pharmacist, when user is a nurse
+1 NEW IEN,VAL,ND
+2 SET VAL=1
+3 IF (+PSJSYSU'=1)!($PIECE($GET(^PS(53.1,+PSGDA,0)),"^",9)'="N")
QUIT VAL
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PS(53.1,+PSGDA,"A",IEN))
if 'IEN
QUIT
SET ND=$GET(^(IEN,0))
IF $PIECE($GET(^PS(53.3,+$PIECE(ND,"^",3),0)),"^",2)="FP"
SET VAL=0
QUIT
+5 QUIT VAL
+6 ;
ACTO ;
+1 SET PSGACTO=""
IF $GET(PSGACT)]""
FOR X=1:1:$LENGTH(PSGACT)
SET PSGACTO=PSGACTO_$SELECT($EXTRACT(PSGACT,X)="D":"DC",1:$EXTRACT(PSGACT,X))_" "
+2 if PSGACTO]""
SET PSGACTO=$EXTRACT(PSGACTO,1,$LENGTH(PSGACTO)-1)
QUIT
+3 ;
ACTPRO(PSJDA) ;*366 - check provider credentials
+1 NEW %,X1,X2
+2 if '$DATA(PSJDA)
QUIT ""
+3 SET PSJDA=+PSJDA
+4 if '$GET(PSJDA)
QUIT ""
+5 ;check for zero node
+6 if '$DATA(^VA(200,PSJDA,0))
QUIT ""
+7 SET X1=$GET(^VA(200,PSJDA,0))
+8 ;check for DISUSER
+9 if $PIECE(X1,U,7)=1
QUIT "0^DISUSER"
+10 ;check for provider key
+11 if '$DATA(^XUSEC("PROVIDER",PSJDA))&'$DATA(^XUSEC("ORELSE",PSJDA))
QUIT "0^NO PROVIDER KEY"
+12 ;check termination date is <today's date
+13 SET %=+$PIECE(X1,U,11)
IF %>0
IF %<DT
QUIT "0^TERMINATED^"_%
+14 ;check inactivation date is <today's date
+15 SET X2=$GET(^VA(200,PSJDA,"PS"))
+16 if X2=""!('X2)
QUIT "0^NOT AUTHORIZED TO WRITE"
+17 SET %=+$PIECE(X2,U,4)
IF %>0
IF %<DT
QUIT "0^INACTIVATED^"_%
+18 ;Default:
+19 QUIT 1
+20 ;
