source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPR.m@ 1800

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