- 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 Jan 18, 2025@03:02:20 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