- PSGPR ;BIR/CML3-PATIENT PROFILE ;29-May-2012 14:31;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**1011,110,111,169,1015**;16 DEC 97;Build 62
- ; Modified - IHS/MSC/PLS - 03/28/2011 - Line PP0+2
- ;* 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
- 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
- .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 ;
- D SETPTCX^APSPFUNC(PSGP) ;IHS/MSC/PLS - 03/28/2011
- 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
- PSGPR ;BIR/CML3-PATIENT PROFILE ;29-May-2012 14:31;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**1011,110,111,169,1015**;16 DEC 97;Build 62
- +2 ; Modified - IHS/MSC/PLS - 03/28/2011 - Line PP0+2
- +3 ;* N PSJNEW,PSGPTMP,PPAGE,PSGOEPRF S PSJNEW=1
- +4 NEW PSGLI,PSGOE,PSGOEEWF,PSGOH,PSGWD,PSJPWDO,PSJSTOP,PSJTEAM
- +5 NEW ACTION,CONT,PAT,LD,LN2,PFLG,PSJNEW,PSGPTMP,PPAGE,PSGOEPRF
- SET PSJNEW=1
- +6 ;
- +7 SET PSJOPC="UD"
- +8 DO ENCV^PSGSETU
- +9 ;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
- +10 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
- +11 KILL PSJSEL,Y
- FOR
- KILL ^TMP("PSJSELECT",$JOB),PSJSEL
- DO ^PSGSEL
- IF "^"[PSGSS
- QUIT
- SET PSJSEL("SELECT")=PSGSS
- SET PSJSTOP=""
- Begin DoDot:2
- +12 IF (PSJSEL("SELECT")="P")
- DO P^PSJPDIR
- IF (PSJSEL("SELECT")="W")
- DO W^PSJPDIR
- IF (PSJSEL("SELECT")="G")
- DO G^PSJPDIR
- +13 ; PSJ*5*169 Check PSJSTOP before continuing.
- +14 IF $GET(PSJSTOP)=1
- QUIT
- +15 IF PSJSEL("SELECT")'="P"
- IF PSJSEL("SELECT")'="L"
- DO RBPPN^PSJPDIR
- +16 IF $GET(PSJSTOP)=1
- QUIT
- +17 IF (((PSGSS="W")!(PSGSS="G"))&($GET(Y)<0))
- QUIT
- IF ((PSGSS="P")&'$DATA(PSJSEL("P")))
- QUIT
- +18 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
- +19 ;
- 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
- End DoDot:1
- +3 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
- +4
- *** ERROR ***
- +5
- *** ERROR ***
- +6 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
- +7 QUIT
- +8 ;
- 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 ;IHS/MSC/PLS - 03/28/2011
- DO SETPTCX^APSPFUNC(PSGP)
- +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
