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

PSGDS0.m

Go to the documentation of this file.
  1. PSGDS0 ;BIR/CML3-GATHER INFO FOR DISCHARGE SUMMARY ;25 Feb 99 / 9:30 AM
  1. ;;5.0; INPATIENT MEDICATIONS ;**4,8,24,58**;16 DEC 97
  1. ;
  1. ;Reference to ^PS(55 is supported by DBIA 2191
  1. ;Reference to ^PSDRUG is supported by DBIA 2192
  1. ;
  1. GOD ; gather order data
  1. S N=0,ND=$G(^PS(55,PSGP,5,PSJJORD,0)),ND2=$G(^(2)),SI=$P($G(^(6)),"^"),DRG=$G(^(.2)),DO=$P(DRG,"^",2) ; I $D(^PSDRUG(+DRG,8)),$P(^(8),"^",5) S DRG=$P(^(8),"^",5),N=1
  1. ; S WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0),DRG=$G(^PSDRUG(+DRG,0))
  1. S SD=$P(ND2,"^",2),FD=$P(ND2,"^",4),ND2=$P(ND2,"^"),RTE=+$P(ND,"^",3),ST=$P(ND,"^",9),RTE=$E($$ENMRN^PSGMI(RTE),1,5),SPH="",NF=""
  1. S ND=$P(ND,"^",7),ND=$$ENSTN^PSGMI(ND) F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
  1. S (CNT,DRGN,DDRG)=""
  1. F JJ=0:0 S JJ=$O(^PS(55,PSGP,5,PSJJORD,1,JJ)) Q:'JJ D
  1. .S X=$G(^PS(55,PSGP,5,PSJJORD,1,JJ,0))
  1. .I $P(X,U,3),($P(X,U,3)<PSGDT) Q
  1. .S CNT=CNT+1,DDRG=JJ
  1. .S SPH=SPH_$P($G(^PSDRUG(+X,0)),U,3)
  1. S DDRG=$S('CNT:"NO",CNT>1:"MULTIPLE",1:$G(^PS(55,PSGP,5,PSJJORD,1,DDRG,0)))
  1. ;I $P(DDRG,U,2) S DO=$P(DDRG,U,2)
  1. ;S DRGN=$S(DRGN:$$ENPDN^PSGMI(+DRG),$P($G(^PSDRUG(+DDRG,8)),"^",5):$P(^PSDRUG($P(^(8),"^",5),0),"^"),1:$P(^PSDRUG(+DDRG,0),"^"))
  1. S DRGN=$S('DDRG:$$ENPDN^PSGMI(+DRG),$P($G(^PSDRUG(+DDRG,8)),"^",5):$P(^PSDRUG($P(^(8),"^",5),0),"^"),1:$P(^PSDRUG(+DDRG,0),"^"))
  1. S:DDRG SPH=$S($P($G(^PSDRUG(+DDRG,8)),"^",5):$P(^PSDRUG($P(^(8),"^",5),0),"^",3),1:SPH)
  1. S UC="" F Q=0:0 S Q=$O(^PS(55,PSGP,5,PSJJORD,1,Q)) Q:'Q S DD=$G(^(Q,0)) I DD,$S('$P(DD,"^",3):1,1:$P(DD,"^",3)>DT) S UC=UC+($P($G(^PSDRUG(+DD,660)),"^",6)*$S('$P(DD,"^",2):1,1:$P(DD,"^",2)))
  1. ;
  1. ;
  1. S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y) S ^TMP("PSG",$J,PSGAPWDN,PN,DRGN_"^"_PSJJORD)=DO_"^"_RTE_"^"_ST_"^"_ND2_"^"_SD_"^"_FD_"^"_SPH_"^"_N_"^"_NF_"^"_ND_"^"_UC_"^"_+DDRG S:Y]"" ^(DRGN_"^"_PSJJORD,1)=Y Q
  1. ;
  1. PAT ;
  1. D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PN=$P(PSGP(0),"^")_"^"_PSGP I PSJSEL("SELECT")="P" S PSGAPWDN=$S(PSJPWDN]"":PSJPWDN,1:"Outpatient")
  1. F STRT=PSGDT:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:'STRT F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:('PSJJORD)!(PSGBLANK=1) D GOD
  1. Q:'$D(^TMP("PSG",$J,PSGAPWDN,PN)) K VASD,^UTILITY("VASD",$J) S DFN=PSGP,(PSGOD,SC)="" D SDA^VADPT I $D(^UTILITY("VASD",$J,1,"E")),$D(^("I")) S SC=$P(^("E"),"^",2),PSGOD=$$ENDTC^PSGMI(+^("I"))
  1. K VAEL S ELIG="" D ELIG^VADPT I $D(VAEL) S ELIG=$S(VAEL(3)["^":VAEL(3),1:"^")_"^"_VAEL(4)_"^"_VAEL(6)
  1. S ^TMP("PSG",$J,PSGAPWDN,PN)=$P(PSJPSEX,U,2)_U_$E($P(PSJPDOB,U,2),1,10)_";"_PSJPAGE_U_$P(PSJPSSN,U,2)_U_PSJPDX_U_$S(PSJPRB]"":PSJPRB,1:"*NF*")_U_$E($P(PSJPAD,U,2),1,10)_U_$E($P(PSJPTD,U,2),1,10)_U_$E(PSGOD,1,8)_U_SC_U_+PSJPWT,^(PN,0)=ELIG
  1. Q
  1. ;
  1. GDT ;
  1. K %DT S %DT="EFTX",Y=-1,%DT(0)=$S(N["R":PSGDT,1:STT) F W !!,"Enter ",N," date: " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D DTM^PSGDS:X?1."?",^%DT Q:Y>0
  1. I X'="^" S:N["R" STT=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0001) S:N["O" STP=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)
  1. K %DT Q
  1. ;
  1. ;
  1. EN ; entry point
  1. S X="" I '(PSGBLANK) I (PSJSEL("SELECT")'="P") D NOW^%DTC S PSGDT=% F N="START","STOP" D GDT Q:X="^"
  1. Q:X="^" K ZTSAVE S:PSJSEL("SELECT")'="P" (ZTSAVE("STT"),ZTSAVE("STP"))="" F X="PSGP","PSJSEL(","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGBLANK","PSGPAT(","PSGPTMP","PPAGE" S ZTSAVE(X)=""
  1. W !,"...this may take a few minutes...(you should QUEUE this report)..."
  1. S PSGTIR="ENQ^PSGDS0",ZTDESC="DISCHARGE SUMMARY" D ENDEV^PSGTI Q:POP!$D(IO("Q"))
  1. ;
  1. ENQ ; queued entry point
  1. K ^TMP("PSG",$J) S PSJACNWP=1 N RBP S RBP=$S($D(PSJSEL("RBP")):PSJSEL("RBP"),1:"P") D @("P"_PSJSEL("SELECT")) D:'PSGBLANK ^PSGDSP D ^%ZISC
  1. K %DT,AM,DRGN,LQ,N,SC,SPH,UC,VASD,^TMP("PSG",$J),^UTILITY("VASD",$J) Q
  1. ;
  1. PG ;
  1. F PSGAPWD=0:0 S PSGAPWD=$O(^PS(57.5,"AC",PSGAPWG,PSGAPWD)) Q:'PSGAPWD I $D(^DIC(42,PSGAPWD,0)),$P(^(0),"^")]"" S PSGAPWDN=$P(^(0),"^") D PW Q:$G(NP)="^"
  1. Q
  1. ;
  1. PW ;
  1. I $D(PSJSEL("TM")) S TM="" F S TM=$O(PSJSEL("TM",TM)) Q:TM="" S PSGPATM(TM)=TM
  1. S PSGP=0
  1. F S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D Q:$G(NP)="^"
  1. .I PSGBLANK=1 D EN^PSGDSP1 Q
  1. .S LQ=0,Q=STT-.000001 F Q:LQ S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q D
  1. ..F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $P($G(^PS(55,PSGP,5,QQ,2)),"^",2)'>STP S RB=$G(^DPT(PSGP,.101)),TM="zz" D S LQ=1 Q
  1. ..I '$D(PSGATM) D SET Q
  1. ..S:RB TM=$O(^PS(57.7,"AWRT",PSGAPWD,RB,0)) S:'TM TM="zz" I $D(PSGPATM("ALL"))!$D(PSGPATM(TM)) D SET Q
  1. I $D(^TMP("PSGDS",$J)) N PSGX S PSGX="^TMP(""PSGDS"",$J)" F S PSGX=$Q(@PSGX) Q:PSGX'[("""PSGDS"""_","_$J) S PSGP=$G(@PSGX) D PAT Q:$G(X)?1"^"."^"
  1. Q
  1. ;
  1. SET ;
  1. S:TM'["zz" TM=$G(^PS(57.7,$G(PSGAPWD),1,TM,0)) I $G(RB)="" S RB="z"
  1. I RBP="P" D ^PSJAC S ^TMP("PSGDS",$J,TM,PSGP(0))=PSGP Q
  1. I RBP="R" S ^TMP("PSGDS",$J,TM,RB)=PSGP
  1. Q
  1. ;
  1. PP ;
  1. N PAT S PAT="" F S PAT=$O(PSGPAT(PAT)) Q:PAT="" S PSGP=$G(PSGPAT(PAT)) D @$S(PSGBLANK=1:"EN^PSGDSP1",1:"PAT") Q:$G(NP)="^"
  1. Q