PSGPR ;BIR/CML3-PATIENT PROFILE ;19 SEP 96 / 3:59 PM
;;5.0; INPATIENT MEDICATIONS ;**110,111,169**;16 DEC 97
;* N PSJNEW,PSGPTMP,PPAGE,PSGOEPRF S PSJNEW=1
N PSGLI,PSGOE,PSGOEEWF,PSGOH,PSGWD,PSJPWDO,PSJSTOP,PSJTEAM
N ACTION,CONT,PAT,LD,LN2,PFLG,PSJNEW,PSGPTMP,PPAGE,PSGOEPRF S PSJNEW=1
;
S PSJOPC="UD"
D ENCV^PSGSETU
;I '$D(XQUIT) F PSGPR=0:0 S (PSGP,PSGPRWD,PSGPRWG)=0,(PSGPRWDN,PSGPRWGN)="",PSGSSH="PPR" S PSGPTMP=0,PPAGE=1 D GWP^PSJPDIR Q:'$D(PSJSEL) D @PSJSEL("SELECT") D ENL^PSGOU I "^N"'[PSGOL D GO
I '$D(XQUIT) F PSGPR=0:0 S (PSGP,PSGPRWD,PSGPRWG)=0,(PSGPRWDN,PSGPRWGN)="",PSGSSH="PPR" S PSGPTMP=0,PPAGE=1 D Q:'$D(PSJSEL("SELECT"))
.K PSJSEL,Y F K ^TMP("PSJSELECT",$J),PSJSEL D ^PSGSEL Q:"^"[PSGSS S PSJSEL("SELECT")=PSGSS,PSJSTOP="" D
..D:(PSJSEL("SELECT")="P") P^PSJPDIR D:(PSJSEL("SELECT")="W") W^PSJPDIR D:(PSJSEL("SELECT")="G") G^PSJPDIR
..; PSJ*5*169 Check PSJSTOP before continuing.
..Q:$G(PSJSTOP)=1
..I PSJSEL("SELECT")'="P",PSJSEL("SELECT")'="L" D RBPPN^PSJPDIR
..Q:$G(PSJSTOP)=1
..Q:(((PSGSS="W")!(PSGSS="G"))&($G(Y)<0)) Q:((PSGSS="P")&'$D(PSJSEL("P")))
..S (PSGP,WD,WG)=0 S PSGPTMP=0,PPAGE=1 D @PSGSS Q:(((PSGSS="L")!(PSGSS="C"))&($G(Y)<0)) D ENL^PSGOU I "^N"'[PSGOL D GO
;
DONE ;
D:'$D(PSGOEPRF) ENKV^PSGSETU K AND,AT,C,CA,DOB,DRGI,FQC,MF,ND,NF,O,ON,PG,PN,PSGON,PSGORD,PRI,PSGONC,PSGONR,PSGONV,PSGSEL,PX,^TMP("PSGPR",$J)
K RCT,PSGAPTM,PSGOL,PSGOS,PSGPR,PSGSS,PSGSSH,PSGPATM,PSGPRWD,PSGPRWDN,PSGPRWG,PSGPRWGN,PSGPRA,PSGPRP,PSJOPC,PSJSEL,S1,S2,S3,S4,HDT,PSGODT,QFLG,RF,SD,SLS,SSN,TF,TM,UD,UDU,WD,WDP,WT,ZTOUT,ZTSK,OD,PDRG
Q
;
GO ;
S PSGPRP="P",PSGPRA="" S PSGSS=PSJSEL("SELECT") G:PSGSS'="P" ENDEV
K DIR S DIR(0)="SAO^P:PROFILE;E:EXPANDED VIEWS;B:BOTH",DIR("A")="Show PROFILE only, EXPANDED VIEWS only, or BOTH: ",DIR("B")="PROFILE",DIR("?")="^D PH^PSGPR" W ! D ^DIR K DIR Q:"^"[Y S PSGPRP=Y
I "EB"[PSGPRP F R !!,"Show SHORT, LONG, or NO activity log? NO// ",AT:DTIME D ALC^PSGVW0 I Q S PSGPRA=AT Q
Q:PSGPRA="^"
ENDEV ;
K ZTSAVE S PSGTIR="ENQ^PSGPR",ZTDESC="PATIENT PROFILE" F X="PSGP","PSGP(","PSGSS","PSGPRWD","PSGPRWG","PSGPRWDN","PSGPRWGN","PSGOL","PSGPRA","PSGPRP","PSGPTMP","PSJSEL(","PPAGE" S ZTSAVE(X)=""
D ENDEV^PSGTI I POP!$D(IO("Q")) G:$D(PSGOEPRF) DONE Q
;
ENQ ;
K ^TMP("PSGPR",$J)
K PSGVBY N RB,ATM S PSGPR=IO'=IO(0)!($E(IOST)'="C") N RBP S RBP=$S($D(PSJSEL("RBP")):PSJSEL("RBP"),1:"P") D @("P"_PSGSS) I PSGPR W:$Y @IOF D ^%ZISC
G:$D(PSGOEPRF) DONE Q
;
G ; get ward group
S PSGPRWG=+PSJSEL("WG"),PSGPRWGN=$P(PSJSEL("WG"),"^",2) Q
;
W ; get ward
S PSGPRWD=+PSJSEL("W"),PSGPRWDN=$P(PSJSEL("W"),"^",2)
I $D(PSJSEL("TM")) S TM="" F S TM=$O(PSJSEL("TM",TM)) Q:TM="" S PSGAPTM(TM)=TM
Q
;
C ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: "
S DIR("?")="^D CDIC^PSGVBW" W ! D ^DIR
CDIC ;
K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC S:+Y>0 CL=+Y
W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
Q
;
P ; get patient
N PAT S PAT="" F S PAT=$O(PSJSEL("P",PAT)) Q:PAT="" S PSGP(PAT)=$O(PSJSEL("P",PAT,PSGP))
Q
;
PG ;
F PSGPRWD=0:0 S PSGPRWD=$O(^PS(57.5,"AC",PSGPRWG,PSGPRWD)) Q:'PSGPRWD I $D(^DIC(42,PSGPRWD,0)),$P(^(0),"^")]"" S PSGPRWDN=$P(^(0),"^") D
.F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGPRWDN,PSGP)) Q:'PSGP D
..I RBP="R" S RB=$G(^DPT(PSGP,.101)) S:RB="" RB="zz" S ^TMP("PSGPR",$J,RB,PSGPRWDN,RB)=PSGP
..I RBP="P" D ^PSJAC S ^TMP("PSGPR",$J,PSGPRWDN,PSGP(0))=PSGP
I $D(^TMP("PSGPR",$J)) N PSGX S PSGX="^TMP(""PSGPR"",$J)" F S PSGX=$Q(@PSGX) Q:PSGX'[("""PSGPR"""_","_$J) S PSGP=$G(@PSGX) D PP0 Q:$G(X)?1"^"."^"
Q
;
PW ;
I $D(PSJSEL("TM")) S TM="" F S TM=$O(PSJSEL("TM",TM)) Q:TM="" S PSGPATM(TM)=TM
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGPRWDN,PSGP)) Q:'PSGP S RB=$G(^DPT(PSGP,.101)),TM="zz" D
.I '$D(PSGPATM) D SET Q
.S:RB]"" TM=$O(^PS(57.7,"AWRT",PSGPRWD,RB,0)) S:'TM TM="zz" I $D(PSGPATM("ALL"))!$D(PSGPATM(TM)) D SET Q
I $D(^TMP("PSGPR",$J)) N PSGX S PSGX="^TMP(""PSGPR"",$J)" F S PSGX=$Q(@PSGX) Q:PSGX'[("""PSGPR"""_","_$J) S PSGP=$G(@PSGX) D PP0 Q:$G(X)?1"^"."^"
Q
;
L ;
D L^PSGVBW
Q
;
PL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D PC
Q
;
PC S WDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
S PSGP="" F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:'PSGP S RB=$G(^DPT(PSGP,.101)),TM="zz" D
.D SET Q
I $D(^TMP("PSGPR",$J)) N PSGX S PSGX="^TMP(""PSGPR"",$J)" F S PSGX=$Q(@PSGX) Q:PSGX'[("""PSGPR"""_","_$J) S PSGP=$G(@PSGX) D PP0 Q:$G(X)?1"^"."^"
Q
;
SET ;
S:TM'["zz" TM=$G(^PS(57.7,$G(PSGPRWD),1,TM,0)) I RB="" S RB="z"
I RBP="P" D ^PSJAC S ^TMP("PSGPR",$J,TM,PSGP(0))=PSGP Q
I RBP="R" S ^TMP("PSGPR",$J,TM,RB)=PSGP
Q
;
PP ;
S PAT="" F S PAT=$O(PSGP(PAT)) Q:PAT="" S PSGP=PSGP(PAT) D PP0 Q:$G(X)?1"^"."^"
Q
;
PP0 ;
N PSJACNWP S PSJACNWP=1 D ^PSJAC I PSGPRP'="E" D ^PSGO I PSGPRP="P",'PSGPR D:'PSGON READ^PSJUTL Q:$G(X)?1"^"."^" I PSGON S (PSGONC,PSGONF,PSGONR,PSGONV,PSGPRF)=0 D ENVO^PSGOE0 K PSGPRF Q
Q:PSGPRP="P" I PSGPRP="E" U IO D ENGORD^PSGOU,ENPR^PSGO
I 'PSGPR,PSGSS'="P",'$D(^TMP("PSG",$J)) D READ^PSJUTL Q
S (S1,S2,S3,X)=""
F S S1=$O(^TMP("PSG",$J,S1)) Q:S1="" F S S2=$O(^TMP("PSG",$J,S1,S2)) Q:S2="" F S S3=$O(^TMP("PSG",$J,S1,S2,S3)) Q:S3="" D PP1
D:X'["^"&PSGPR BOT^PSGO K ^TMP("PSG",$J) Q
;
PP1 ;
;* S PSGORD=$P(S3,"^",2)_S1 D EN2^PSGVW I PSGPRA'="N" S AT=PSGPRA D ENA^PSGVW0
S PSGORD=$P(S3,"^",2)_$S(S1["BD":"",S1["B":"P",S1["CD":"",S1["C":"P",1:"U") D EN2^PSGVW I PSGPRA'="N" S AT=PSGPRA D ENA^PSGVW0
S X="" I 'PSGPR S DIR(0)="E" W ! D ^DIR S:$D(DIRUT) X="^" I X["^" S (S1,S2,S3)="~"
Q
;
PH ;
W !!?2,"Enter a 'P' to print ONLY the PROFILE of orders for this patient. Enter an",!,"'E' to print ONLY the EXPANDED VIEW of the orders for this patient. Enter a",!,"'B' to have BOTH the profile (first) and the expanded views print."
W " Enter an '^'to exit." Q
;
ENOR S (DFN,PSGP)=+ORVP
ENLM N PSJNEW,PSGPTMP,PPAGE,PSGOEPRF S PSJNEW=1
S PSJOPC="UD",PSGPTMP=0,PPAGE=1
D ENCV^PSGSETU Q:$D(XQUIT)
S PSJSEL("SELECT")="P",PSJSEL("P",$P($G(^DPT(DFN,0)),U),DFN)="" D ^VADPT
D ^PSJAC,ENL^PSGOU I "^N"'[PSGOL D
.S PSGSS="P",(PSGPRWD,PSGPRWG)=0,(PSGPRWDN,PSGPRWGN)=""
.S PSGP(PSGP(0))=DFN K PSGP(0) D GO
S PSJNKF=1 D READ^PSJUTL G DONE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPR 6250 printed Sep 23, 2025@19:39:08 Page 2
PSGPR ;BIR/CML3-PATIENT PROFILE ;19 SEP 96 / 3:59 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**110,111,169**;16 DEC 97
+2 ;* N PSJNEW,PSGPTMP,PPAGE,PSGOEPRF S PSJNEW=1
+3 NEW PSGLI,PSGOE,PSGOEEWF,PSGOH,PSGWD,PSJPWDO,PSJSTOP,PSJTEAM
+4 NEW ACTION,CONT,PAT,LD,LN2,PFLG,PSJNEW,PSGPTMP,PPAGE,PSGOEPRF
SET PSJNEW=1
+5 ;
+6 SET PSJOPC="UD"
+7 DO ENCV^PSGSETU
+8 ;I '$D(XQUIT) F PSGPR=0:0 S (PSGP,PSGPRWD,PSGPRWG)=0,(PSGPRWDN,PSGPRWGN)="",PSGSSH="PPR" S PSGPTMP=0,PPAGE=1 D GWP^PSJPDIR Q:'$D(PSJSEL) D @PSJSEL("SELECT") D ENL^PSGOU I "^N"'[PSGOL D GO
+9 IF '$DATA(XQUIT)
FOR PSGPR=0:0
SET (PSGP,PSGPRWD,PSGPRWG)=0
SET (PSGPRWDN,PSGPRWGN)=""
SET PSGSSH="PPR"
SET PSGPTMP=0
SET PPAGE=1
Begin DoDot:1
+10 KILL PSJSEL,Y
FOR
KILL ^TMP("PSJSELECT",$JOB),PSJSEL
DO ^PSGSEL
if "^"[PSGSS
QUIT
SET PSJSEL("SELECT")=PSGSS
SET PSJSTOP=""
Begin DoDot:2
+11 if (PSJSEL("SELECT")="P")
DO P^PSJPDIR
if (PSJSEL("SELECT")="W")
DO W^PSJPDIR
if (PSJSEL("SELECT")="G")
DO G^PSJPDIR
+12 ; PSJ*5*169 Check PSJSTOP before continuing.
+13 if $GET(PSJSTOP)=1
QUIT
+14 IF PSJSEL("SELECT")'="P"
IF PSJSEL("SELECT")'="L"
DO RBPPN^PSJPDIR
+15 if $GET(PSJSTOP)=1
QUIT
+16 if (((PSGSS="W")!(PSGSS="G"))&($GET(Y)<0))
QUIT
if ((PSGSS="P")&'$DATA(PSJSEL("P")))
QUIT
+17 SET (PSGP,WD,WG)=0
SET PSGPTMP=0
SET PPAGE=1
DO @PSGSS
if (((PSGSS="L")!(PSGSS="C"))&($GET(Y)<0))
QUIT
DO ENL^PSGOU
IF "^N"'[PSGOL
DO GO
End DoDot:2
End DoDot:1
if '$DATA(PSJSEL("SELECT"))
QUIT
+18 ;
DONE ;
+1 if '$DATA(PSGOEPRF)
DO ENKV^PSGSETU
KILL AND,AT,C,CA,DOB,DRGI,FQC,MF,ND,NF,O,ON,PG,PN,PSGON,PSGORD,PRI,PSGONC,PSGONR,PSGONV,PSGSEL,PX,^TMP("PSGPR",$JOB)
+2 KILL RCT,PSGAPTM,PSGOL,PSGOS,PSGPR,PSGSS,PSGSSH,PSGPATM,PSGPRWD,PSGPRWDN,PSGPRWG,PSGPRWGN,PSGPRA,PSGPRP,PSJOPC,PSJSEL,S1,S2,S3,S4,HDT,PSGODT,QFLG,RF,SD,SLS,SSN,TF,TM,UD,UDU,WD,WDP,WT,ZTOUT,ZTSK,OD,PDRG
+3 QUIT
+4 ;
GO ;
+1 SET PSGPRP="P"
SET PSGPRA=""
SET PSGSS=PSJSEL("SELECT")
if PSGSS'="P"
GOTO ENDEV
+2 KILL DIR
SET DIR(0)="SAO^P:PROFILE;E:EXPANDED VIEWS;B:BOTH"
SET DIR("A")="Show PROFILE only, EXPANDED VIEWS only, or BOTH: "
SET DIR("B")="PROFILE"
SET DIR("?")="^D PH^PSGPR"
WRITE !
DO ^DIR
KILL DIR
if "^"[Y
QUIT
SET PSGPRP=Y
+3 IF "EB"[PSGPRP
FOR
READ !!,"Show SHORT, LONG, or NO activity log? NO// ",AT:DTIME
DO ALC^PSGVW0
IF Q
SET PSGPRA=AT
QUIT
+4 if PSGPRA="^"
QUIT
ENDEV ;
+1 KILL ZTSAVE
SET PSGTIR="ENQ^PSGPR"
SET ZTDESC="PATIENT PROFILE"
FOR X="PSGP","PSGP(","PSGSS","PSGPRWD","PSGPRWG","PSGPRWDN","PSGPRWGN","PSGOL","PSGPRA","PSGPRP","PSGPTMP","PSJSEL(","PPAGE"
SET ZTSAVE(X)=""
+2 DO ENDEV^PSGTI
IF POP!$DATA(IO("Q"))
if $DATA(PSGOEPRF)
GOTO DONE
QUIT
+3 ;
ENQ ;
+1 KILL ^TMP("PSGPR",$JOB)
+2 KILL PSGVBY
NEW RB,ATM
SET PSGPR=IO'=IO(0)!($EXTRACT(IOST)'="C")
NEW RBP
SET RBP=$SELECT($DATA(PSJSEL("RBP")):PSJSEL("RBP"),1:"P")
DO @("P"_PSGSS)
IF PSGPR
if $Y
WRITE @IOF
DO ^%ZISC
+3 if $DATA(PSGOEPRF)
GOTO DONE
QUIT
+4 ;
G ; get ward group
+1 SET PSGPRWG=+PSJSEL("WG")
SET PSGPRWGN=$PIECE(PSJSEL("WG"),"^",2)
QUIT
+2 ;
W ; get ward
+1 SET PSGPRWD=+PSJSEL("W")
SET PSGPRWDN=$PIECE(PSJSEL("W"),"^",2)
+2 IF $DATA(PSJSEL("TM"))
SET TM=""
FOR
SET TM=$ORDER(PSJSEL("TM",TM))
if TM=""
QUIT
SET PSGAPTM(TM)=TM
+3 QUIT
+4 ;
C ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC: "
+2 SET DIR("?")="^D CDIC^PSGVBW"
WRITE !
DO ^DIR
CDIC ;
+1 KILL DIC
SET DIC="^SC("
SET DIC(0)="QEMIZ"
DO ^DIC
KILL DIC
if +Y>0
SET CL=+Y
+2 if X["?"
WRITE !!,"Enter the clinic you want to use to select patients for processing.",!
+3 QUIT
+4 ;
P ; get patient
+1 NEW PAT
SET PAT=""
FOR
SET PAT=$ORDER(PSJSEL("P",PAT))
if PAT=""
QUIT
SET PSGP(PAT)=$ORDER(PSJSEL("P",PAT,PSGP))
+2 QUIT
+3 ;
PG ;
+1 FOR PSGPRWD=0:0
SET PSGPRWD=$ORDER(^PS(57.5,"AC",PSGPRWG,PSGPRWD))
if 'PSGPRWD
QUIT
IF $DATA(^DIC(42,PSGPRWD,0))
IF $PIECE(^(0),"^")]""
SET PSGPRWDN=$PIECE(^(0),"^")
Begin DoDot:1
+2 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGPRWDN,PSGP))
if 'PSGP
QUIT
Begin DoDot:2
+3 IF RBP="R"
SET RB=$GET(^DPT(PSGP,.101))
if RB=""
SET RB="zz"
SET ^TMP("PSGPR",$JOB,RB,PSGPRWDN,RB)=PSGP
+4 IF RBP="P"
DO ^PSJAC
SET ^TMP("PSGPR",$JOB,PSGPRWDN,PSGP(0))=PSGP
End DoDot:2
End DoDot:1
+5 IF $DATA(^TMP("PSGPR",$JOB))
NEW PSGX
SET PSGX="^TMP(""PSGPR"",$J)"
FOR
SET PSGX=$QUERY(@PSGX)
if PSGX'[("""PSGPR"""_","_$JOB)
QUIT
SET PSGP=$GET(@PSGX)
DO PP0
if $GET(X)?1"^"."^"
QUIT
+6 QUIT
+7 ;
PW ;
+1 IF $DATA(PSJSEL("TM"))
SET TM=""
FOR
SET TM=$ORDER(PSJSEL("TM",TM))
if TM=""
QUIT
SET PSGPATM(TM)=TM
+2 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGPRWDN,PSGP))
if 'PSGP
QUIT
SET RB=$GET(^DPT(PSGP,.101))
SET TM="zz"
Begin DoDot:1
+3 IF '$DATA(PSGPATM)
DO SET
QUIT
+4 if RB]""
SET TM=$ORDER(^PS(57.7,"AWRT",PSGPRWD,RB,0))
if 'TM
SET TM="zz"
IF $DATA(PSGPATM("ALL"))!$DATA(PSGPATM(TM))
DO SET
QUIT
End DoDot:1
+5 IF $DATA(^TMP("PSGPR",$JOB))
NEW PSGX
SET PSGX="^TMP(""PSGPR"",$J)"
FOR
SET PSGX=$QUERY(@PSGX)
if PSGX'[("""PSGPR"""_","_$JOB)
QUIT
SET PSGP=$GET(@PSGX)
DO PP0
if $GET(X)?1"^"."^"
QUIT
+6 QUIT
+7 ;
L ;
+1 DO L^PSGVBW
+2 QUIT
+3 ;
PL SET CL=""
FOR
SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
if CL=""
QUIT
DO PC
+1 QUIT
+2 ;
PC SET WDN=$SELECT($DATA(^SC(CL,0)):$PIECE(^(0),"^"),1:"")
+1 SET PSGP=""
FOR
SET PSGP=$ORDER(^PS(53.1,"AD",CL,PSGP))
if 'PSGP
QUIT
SET RB=$GET(^DPT(PSGP,.101))
SET TM="zz"
Begin DoDot:1
+2 DO SET
QUIT
End DoDot:1
+3 IF $DATA(^TMP("PSGPR",$JOB))
NEW PSGX
SET PSGX="^TMP(""PSGPR"",$J)"
FOR
SET PSGX=$QUERY(@PSGX)
if PSGX'[("""PSGPR"""_","_$JOB)
QUIT
SET PSGP=$GET(@PSGX)
DO PP0
if $GET(X)?1"^"."^"
QUIT
+4 QUIT
+5 ;
SET ;
+1 if TM'["zz"
SET TM=$GET(^PS(57.7,$GET(PSGPRWD),1,TM,0))
IF RB=""
SET RB="z"
+2 IF RBP="P"
DO ^PSJAC
SET ^TMP("PSGPR",$JOB,TM,PSGP(0))=PSGP
QUIT
+3 IF RBP="R"
SET ^TMP("PSGPR",$JOB,TM,RB)=PSGP
+4 QUIT
+5 ;
PP ;
+1 SET PAT=""
FOR
SET PAT=$ORDER(PSGP(PAT))
if PAT=""
QUIT
SET PSGP=PSGP(PAT)
DO PP0
if $GET(X)?1"^"."^"
QUIT
+2 QUIT
+3 ;
PP0 ;
+1 NEW PSJACNWP
SET PSJACNWP=1
DO ^PSJAC
IF PSGPRP'="E"
DO ^PSGO
IF PSGPRP="P"
IF 'PSGPR
if 'PSGON
DO READ^PSJUTL
if $GET(X)?1"^"."^"
QUIT
IF PSGON
SET (PSGONC,PSGONF,PSGONR,PSGONV,PSGPRF)=0
DO ENVO^PSGOE0
KILL PSGPRF
QUIT
+2 if PSGPRP="P"
QUIT
IF PSGPRP="E"
USE IO
DO ENGORD^PSGOU
DO ENPR^PSGO
+3 IF 'PSGPR
IF PSGSS'="P"
IF '$DATA(^TMP("PSG",$JOB))
DO READ^PSJUTL
QUIT
+4 SET (S1,S2,S3,X)=""
+5 FOR
SET S1=$ORDER(^TMP("PSG",$JOB,S1))
if S1=""
QUIT
FOR
SET S2=$ORDER(^TMP("PSG",$JOB,S1,S2))
if S2=""
QUIT
FOR
SET S3=$ORDER(^TMP("PSG",$JOB,S1,S2,S3))
if S3=""
QUIT
DO PP1
+6 if X'["^"&PSGPR
DO BOT^PSGO
KILL ^TMP("PSG",$JOB)
QUIT
+7 ;
PP1 ;
+1 ;* S PSGORD=$P(S3,"^",2)_S1 D EN2^PSGVW I PSGPRA'="N" S AT=PSGPRA D ENA^PSGVW0
+2 SET PSGORD=$PIECE(S3,"^",2)_$SELECT(S1["BD":"",S1["B":"P",S1["CD":"",S1["C":"P",1:"U")
DO EN2^PSGVW
IF PSGPRA'="N"
SET AT=PSGPRA
DO ENA^PSGVW0
+3 SET X=""
IF 'PSGPR
SET DIR(0)="E"
WRITE !
DO ^DIR
if $DATA(DIRUT)
SET X="^"
IF X["^"
SET (S1,S2,S3)="~"
+4 QUIT
+5 ;
PH ;
+1 WRITE !!?2,"Enter a 'P' to print ONLY the PROFILE of orders for this patient. Enter an",!,"'E' to print ONLY the EXPANDED VIEW of the orders for this patient. Enter a",!,"'B' to have BOTH the profile (first) and the expanded views print."
+2 WRITE " Enter an '^'to exit."
QUIT
+3 ;
ENOR SET (DFN,PSGP)=+ORVP
ENLM NEW PSJNEW,PSGPTMP,PPAGE,PSGOEPRF
SET PSJNEW=1
+1 SET PSJOPC="UD"
SET PSGPTMP=0
SET PPAGE=1
+2 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
+3 SET PSJSEL("SELECT")="P"
SET PSJSEL("P",$PIECE($GET(^DPT(DFN,0)),U),DFN)=""
DO ^VADPT
+4 DO ^PSJAC
DO ENL^PSGOU
IF "^N"'[PSGOL
Begin DoDot:1
+5 SET PSGSS="P"
SET (PSGPRWD,PSGPRWG)=0
SET (PSGPRWDN,PSGPRWGN)=""
+6 SET PSGP(PSGP(0))=DFN
KILL PSGP(0)
DO GO
End DoDot:1
+7 SET PSJNKF=1
DO READ^PSJUTL
GOTO DONE
