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