PSGVBW1 ;BIR/CML3,MV-NON-VERFIED ORDERS UTILITES ; 5/3/10 3:44pm
;;5.0; INPATIENT MEDICATIONS ;**5,111,241**;16 DEC 97;Build 10
;
;Reference to ^PS(55 is supported by DBIA 2191.
;
ENPROF ;
I +PSJSYSU=1 S PSGOENOF=0 D NOW^%DTC F Q=%:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,4)),$P(^(4),"^",10) S PSGOENOF=1 Q
W !!,$S($P(PSGP(0),"^")]"":$P(PSGP(0),"^"),1:PSGP_";DPT(") W:PSJPBID " (",PSJPBID,")"
D ENL^PSGOU Q:PSGOL["^"
K ZTSAVE S PSGTIR="^PSJAC,^PSGO",ZTDESC="PATIENT PROFILE",PSGPR=1 F X="PSGP","PSGP(0)","PSGPR","PSGOL","PSGPTMP","PPAGE" S ZTSAVE(X)=""
Q:PSGOL="N"
D ENDEV^PSGTI K PSGPR Q:POP!$D(IO("Q"))
S PSGVBW=IO'=IO(0)!($E(IOST)'="C") D ^PSGO D ^%ZISC Q:PSGVBW
PEND K DIR S DIR(0)="E" W ! D ^DIR K DIR Q
;
OUTPT ;Set up Outpatient IV for non/ver pending option.
K ^TMP("PSGVBW",$J)
NEW PSJSTAT,PSJTOO1,PSJPAC1
;I PSJTOO'=2 S PSJSTAT="N" D PSGP
;I PSJTOO'=1 S PSJSTAT="P" D PSGP
S PSJSTAT="N" D PSGP
S PSJSTAT="P" D PSGP
N PSJXR,PSJUDIV S PSJXR(1)=$S(+PSJSYSU=3:"APV",1:"ANV"),PSJXR(2)=$S(+PSJSYSU=3:"APIV",1:"ANIV") ;*PSJ*5*241: added block
F PSJUDIV=1:1:2 F DFN=0:0 S DFN=$O(^PS(55,PSJXR(PSJUDIV),DFN)) Q:'DFN D
. NEW VAIN D INP^VADPT
. I $G(VAIN(4))&(PSGSS="G"&'$D(^PS(57.5,"AB",+VAIN(4)))) D
.. S PSGP=DFN D ^PSJAC S WDN="ZZ" D IF^PSGVBW
D ^PSGVBW0
S Y=-1
Q
PSGP ;
F PSGP=0:0 S PSGP=$O(^PS(53.1,"AS",PSJSTAT,PSGP)) Q:'PSGP D
. NEW VAIN S DFN=PSGP D INP^VADPT
. I '+(VAIN(4))!(PSGSS="G"&'$D(^PS(57.5,"AB",+VAIN(4)))) D
.. ;I PSJSTAT="N",'+VAIN(4) Q
.. D ^PSJAC S WDN="ZZ" D IF^PSGVBW
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGVBW1 1637 printed Dec 13, 2024@02:03:25 Page 2
PSGVBW1 ;BIR/CML3,MV-NON-VERFIED ORDERS UTILITES ; 5/3/10 3:44pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**5,111,241**;16 DEC 97;Build 10
+2 ;
+3 ;Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
ENPROF ;
+1 IF +PSJSYSU=1
SET PSGOENOF=0
DO NOW^%DTC
FOR Q=%:0
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
if 'Q
QUIT
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
if 'QQ
QUIT
IF $DATA(^PS(55,PSGP,5,QQ,4))
IF $PIECE(^(4),"^",10)
SET PSGOENOF=1
QUIT
+2 WRITE !!,$SELECT($PIECE(PSGP(0),"^")]"":$PIECE(PSGP(0),"^"),1:PSGP_";DPT(")
if PSJPBID
WRITE " (",PSJPBID,")"
+3 DO ENL^PSGOU
if PSGOL["^"
QUIT
+4 KILL ZTSAVE
SET PSGTIR="^PSJAC,^PSGO"
SET ZTDESC="PATIENT PROFILE"
SET PSGPR=1
FOR X="PSGP","PSGP(0)","PSGPR","PSGOL","PSGPTMP","PPAGE"
SET ZTSAVE(X)=""
+5 if PSGOL="N"
QUIT
+6 DO ENDEV^PSGTI
KILL PSGPR
if POP!$DATA(IO("Q"))
QUIT
+7 SET PSGVBW=IO'=IO(0)!($EXTRACT(IOST)'="C")
DO ^PSGO
DO ^%ZISC
if PSGVBW
QUIT
PEND KILL DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
QUIT
+1 ;
OUTPT ;Set up Outpatient IV for non/ver pending option.
+1 KILL ^TMP("PSGVBW",$JOB)
+2 NEW PSJSTAT,PSJTOO1,PSJPAC1
+3 ;I PSJTOO'=2 S PSJSTAT="N" D PSGP
+4 ;I PSJTOO'=1 S PSJSTAT="P" D PSGP
+5 SET PSJSTAT="N"
DO PSGP
+6 SET PSJSTAT="P"
DO PSGP
+7 ;*PSJ*5*241: added block
NEW PSJXR,PSJUDIV
SET PSJXR(1)=$SELECT(+PSJSYSU=3:"APV",1:"ANV")
SET PSJXR(2)=$SELECT(+PSJSYSU=3:"APIV",1:"ANIV")
+8 FOR PSJUDIV=1:1:2
FOR DFN=0:0
SET DFN=$ORDER(^PS(55,PSJXR(PSJUDIV),DFN))
if 'DFN
QUIT
Begin DoDot:1
+9 NEW VAIN
DO INP^VADPT
+10 IF $GET(VAIN(4))&(PSGSS="G"&'$DATA(^PS(57.5,"AB",+VAIN(4))))
Begin DoDot:2
+11 SET PSGP=DFN
DO ^PSJAC
SET WDN="ZZ"
DO IF^PSGVBW
End DoDot:2
End DoDot:1
+12 DO ^PSGVBW0
+13 SET Y=-1
+14 QUIT
PSGP ;
+1 FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.1,"AS",PSJSTAT,PSGP))
if 'PSGP
QUIT
Begin DoDot:1
+2 NEW VAIN
SET DFN=PSGP
DO INP^VADPT
+3 IF '+(VAIN(4))!(PSGSS="G"&'$DATA(^PS(57.5,"AB",+VAIN(4))))
Begin DoDot:2
+4 ;I PSJSTAT="N",'+VAIN(4) Q
+5 DO ^PSJAC
SET WDN="ZZ"
DO IF^PSGVBW
End DoDot:2
End DoDot:1
+6 QUIT
