Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGVBWP

PSGVBWP.m

Go to the documentation of this file. 
  1. PSGVBWP ;BIR/CML3-INPATIENT MEDICATIONS PROFILE FROM NON-VERIFIED/PENDING ;25 SEP 97 / 7:42 AM
  1.  ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
  1.  N PFLG,PSJNEW,PSGPTMP,PPAGE,QFLG S PSJNEW=1
  1.  N PSGLI,PSGWD,PSJAT,PSJPNRB,PSJPWDO,PSJSTOP,PSJTEAM
  1.  ;
  1. EN ;
  1.  G:$D(XQUIT) DONE
  1.  ;D @$S('$D(PSJEXTP):"^PSIVXU",1:"ENCV^PSGSETU")
  1.  ;G:$D(XQUIT) DONE S PSGPTMP=0,PPAGE=1 K PSJSEL D @$S($D(PSJEXTP):"P^PSJPDIR",1:"GWP^PSJPDIR") G:$G(PSJSTOP) DONE S:$D(PSJEXTP) PSJSEL("SELECT")="P"
  1.  D ENL^PSJO3 G:"^N"[PSJOL EN D GO
  1.  ;
  1. DONE ;
  1.  K ^TMP("PSJON",$J),^TMP("PSJ",$J)
  1.  D ENIVKV^PSGSETU K AND,AT,C,CA,DDH,DFN,DN,DOB,DRGI,DRGN,DRGT,FIL,FQC,HDR,I1,J,JJ,MF,NF,O,OD,ON,ON55,P,P1,PDRG,PG,PPN,PRI,PRIV,PSGLMT,PSGOE,PSGONC,PSGONR,PSGONV,PSGORD,PSGSS,PSGSSH,PSGON,PSGPR,PSGPRP
  1.  K PSIVAC,PSIVCT,PSIVREA,PSIVSCR,PSIVUP,PSIVX
  1.  K PSJACNWP,PSJACOK,PSJDEV,PSJDBL,PSJION,PSJOL,PSJON,PSJOS,PSJP,PSJSEL,PSJSS,PSJSSH,PSJPRW,PSJPRWN,PSJPRWG,PSJPRWGN
  1.  K PSJOPC,PSJORD,PSJQ,PSJIVOF,PSJOCNT,PSJPR,PSJPRA,PSJPRF,PSJPRP,PSJON,PSJS1,PSJS2,PSJS3,PSJS4,PSJPR,PX,HDT,PSGODT,RF,SD,SLS,SSN,TF,UD,WD,WDP,WT,PSJORIFN,RB,RCT,SUB,XQUIT,ZTOUT
  1.  ;* 
  1.  ;* K PSGLI,PSGWD,PSJAT,PSJPNRB,PSJPWDO,PSJSTOP,PSJTEAM
  1.  Q
  1.  ;
  1. GO ;
  1.  ;S PSJPRP="P",PSJPRA="" G:PSJSEL("SELECT")'="P" DEV
  1.  ;N 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^PSJPR" W ! D ^DIR G:"^"[Y EN S PSJPRP=Y
  1.  ;I "EB"[PSJPRP F  R !!,"Show SHORT, LONG, or NO activity log?  NO// ",AT:DTIME D ALC^PSGVW0 I Q S PSJPRA=AT Q
  1.  ;G:PSJPRA="^" EN
  1. DEV ;
  1.  K PSJSEL S PSJSEL("SELECT")="P" F X=0:0 S X=$O(^TMP("PSJSELECT",$J,X)) Q:'X  D
  1.  .S Y=$G(^TMP("PSJSELECT",$J,X)) I $P(Y,U)=""!($P(Y,U,2)="") Q
  1.  .S PSJSEL("P",$P(Y,U),$P(Y,U,2))=""
  1.  S PSJPRP="P",PSJOS=$P(PSJSYSP0,"^",11)
  1.  K ZTSAVE S PSGTIR="ENQ^PSGVBWP",ZTDESC="INPATIENT PATIENT PROFILE" F X="DFN","PSJSEL(","PSJOL","PSJOS","PSJPRA","PSJPRP","PSGPTMP","PPAGE","PSJEXTP","PSJHDATE" S ZTSAVE(X)=""
  1.  D ENDEV^PSGTI Q:POP  D:'$D(IO("Q")) ENQ
  1.  Q
  1.  ;
  1. ENQ ;
  1.  S Y="PSJPR" F X="W","WG" S:$D(PSJSEL(X)) @(Y_X)=+PSJSEL(X),@(Y_X_"N")=$P(PSJSEL(X),U,2)
  1.  S PSJACNWP=1 K ^TMP("PSJAT",$J) S PSJPR=IO'=IO(0)!($E(IOST)'="C"),PSGPRP=PSJPRP
  1.  I PSJSEL("SELECT")="P" S PPN="" F  S PPN=$O(PSJSEL("P",PPN)) Q:PPN=""  D  Q:$G(X)?1"^"."^"
  1.  .F DFN=0:0 S (PSGP,DFN)=$O(PSJSEL("P",PPN,DFN)) Q:'DFN  D ENBOTH^PSJAC,PP Q:$G(X)?1"^"."^"
  1.  D:PSJSEL("SELECT")'="P" @("P"_PSJSEL("SELECT")) I PSJPR W:$Y @IOF D ^%ZISC,DONE
  1.  Q
  1.  ;
  1. PG ;
  1.  ;F PSJPRW=0:0 S PSJPRW=$O(^PS(57.5,"AC",PSJPRWG,PSJPRW)) Q:'PSJPRW  S PSJPRWN=$P($G(^DIC(42,+PSJPRW,0)),"^") I PSJPRWN]"" D PW Q:$G(X)="^"
  1.  Q
  1.  ;
  1. PW ;
  1.  ;K ^TMP("PSJAT",$J) F DFN=0:0 S (DFN,PSGP)=$O(^DPT("CN",PSJPRWN,DFN)) Q:'DFN  D
  1.  ;.S RB=$P($G(^DPT(DFN,.101)),U),PPN=$P($G(^(0)),U),X=$S(PSJSEL("RBP")="R":RB,1:PPN),AT=""
  1.  ;.I $D(PSJSEL("TM")) S:RB]"" AT=$O(^PS(57.7,"AWRT",PSJPRW,RB,0)) Q:$S($D(PSJSEL("TM","ALL")):0,AT="":1,1:'$D(PSJSEL("TM",AT)))
  1.  ;.F Y="AT","RB","X" S:@Y="" @Y="ZZ"
  1.  ;.S ^TMP("PSJAT",$J,AT,X,DFN)=""
  1.  ;K PSJDBL S PSJAT="" F  S PSJAT=$O(^TMP("PSJAT",$J,PSJAT)) Q:PSJAT=""!$G(PSJDBL)  D
  1.  ;.S PSJPNRB="" F  S PSJPNRB=$O(^TMP("PSJAT",$J,PSJAT,PSJPNRB)) Q:PSJPNRB=""  S (DFN,PSGP)=+$O(^TMP("PSJAT",$J,PSJAT,PSJPNRB,0)) D ENBOTH^PSJAC,PP I $G(X)["^" S:X="^^" PSJDBL=1 Q
  1.  Q
  1.  ;
  1. PP ;
  1.  I PSJPRP'="E" D ^PSJO I PSJPRP="P",'PSJPR D:'PSJON READ^PSJUTL Q:$G(X)?1"^"."^"  I PSJON S PSJPRF=1 D ENVW^PSJOE0 K PSGPRF Q
  1.  Q:PSJPRP="P"  I PSJPRP="E" U IO S PSJON=0,PSJDEV=PSJPR D @$S($D(PSJEXTP):"EN^PSJH1,ENGET^PSJO3",1:"EN^PSJO1(3),ENGET^PSJO3")
  1.  I 'PSJPR,PSJSEL("SELECT")'="P",'$D(^TMP("PSG",$J)) D READ^PSJUTL Q
  1.  I PSJPRP'="E",'PSJPR D PP3 Q:$D(DUOUT)!$D(DTOUT)
  1.  S (PSJS1,PSJS2,PSJS3,PSJS4,X)=""
  1.  F PSJQ=0:0 S PSJS1=$O(^TMP("PSJ",$J,PSJS1)) Q:PSJS1=""  F PSJQ=0:0 S PSJS2=$O(^TMP("PSJ",$J,PSJS1,PSJS2)) Q:PSJS2=""  F PSJQ=0:0 S PSJS3=$O(^TMP("PSJ",$J,PSJS1,PSJS2,PSJS3)) Q:PSJS3=""  D PP1
  1.  D:X'["^"&PSJPR BOT^PSJO3 K ^TMP("PSJ",$J) Q
  1.  ;
  1. PP1 ;
  1.  F PSJQ=0:0 S PSJS4=$O(^TMP("PSJ",$J,PSJS1,PSJS2,PSJS3,PSJS4)) Q:PSJS4=""  D PP2
  1.  Q
  1.  ;
  1. PP2 ; Display selected order.
  1.  N PSJPRF,PSJLM S PSJORD=PSJS4 I $S(PSJORD["V":1,PSJORD["P":$P($G(^PS(53.1,+PSJORD,0)),U,4)="F",1:0) D  Q
  1.  .S PSJPRF=1 D ENINP^PSIVOPT(PSGP,PSJORD),PP3 Q:$D(DUOUT)!$D(DTOUT)  I PSJPRA'="N" I PSJORD'["P" D ENLOG^PSIVVW1,PP3 Q
  1.  S PSGORD=PSJORD D EN2^PSGVW,PP3 Q:$D(DUOUT)!$D(DTOUT)  I PSJPRA'="N",(PSGORD["U") S AT=PSJPRA D ENA^PSGVW0 D PP3
  1.  Q
  1. PP3 S X="" I 'PSJPR K DIR S DIR(0)="E" D ^DIR S:$D(DUOUT)!$D(DTOUT) X="^" I X["^" S (PSJS1,PSJS2,PSJS3,PSJS4)="~"
  1.  Q
  1.  ;
  1. PH ;
  1.  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."
  1.  W "  Enter an '^'to exit." Q
  1.  ;
  1. ENOR S (PSGP,DFN)=+ORVP,PSGP(0)=^DPT(PSGP,0)
  1. ENLM N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
  1.  S PSGPTMP=0,PPAGE=1
  1.  D ENCV^PSGSETU
  1.  D ENBOTH^PSJAC D:$D(PSJEXTP) CNV^PSJP D ENL^PSJO3 I "^N"'[PSJOL S PSJSEL("SELECT")="P",PSJSEL("P",PSGP(0),PSGP)="",(PSJPRW,PSJPRWG)=0,(PSJPRWN,PSJPRWGN)="",XQUIT="YES" D GO
  1.  S PSJNKF=1 D READ^PSJUTL G DONE