GMTSDGCH ; SLC/KER/NDBI - Extended ADT Hist ; 09/21/2001
;;2.7;Health Summary;**28,35,47**;Oct 20, 1995
;
; External References
; DBIA 17 ^DGPM("APCA"
; DBIA 17 ^DGPM("ATID1"
; DBIA 17 ^DGPM("ATS"
; DBIA 10035 ^DPT( fields .01,2,3 Read w/Fileman
; DBIA 2929 DSP^A7RHSM (NDBI)
; DBIA 2929 LST^A7RHSM (NDBI)
; DBIA 10015 EN^DIQ1 (file #2)
; DBIA 10061 ELIG^VADPT
; DBIA 10061 IN5^VADPT
; DBIA 10061 KVAR^VADPT
;
MAIN ; Loop through admissions starting from most recent
N FLAG,IN,IM,ADA,ADM,MDA,MDM,X,DOC,CNTR,CODE,TYPE,TT,SPEC,ITS,TS,TSDM,TSDA,VAHOW,VA200,GMC,GMMDA,PTF K VAIP
S CNTR=$S(+($G(GMTSNDM))>0:GMTSNDM,1:100),VA200=1,VAHOW=1,FLAG=-1,ADM=GMTS1,GMC=0
D DISAB,FADM
D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) LST^A7RHSM(DFN,.A7RHS)
F S ADM=$O(^DGPM("ATID1",DFN,ADM)) D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) DSP^A7RHSM(ADM) Q:('ADM)!(ADM>GMTS2)!(CNTR=0)!('DFN) D
. S GMC=0 D MVTS I GMC>0 D
. . D ICDP^GMTSDGC2(DFN,+($G(PTF))),ICDS^GMTSDGC2(DFN,+($G(PTF)))
D KVAR^VADPT K ^UTILITY($J)
K A7RHS
Q
MVTS ; Loop through mvts chronologically, per admission
S ADA=0,ADA=$O(^DGPM("ATID1",DFN,ADM,ADA)) Q:'ADA
N VAIP,PREVDR,PREVSP,PREVAP,PREVWD
K ^UTILITY($J)
S (VAIP("E"),GMMDA)=ADA D IN5^VADPT
I $D(VAIP) D CKP^GMTSUP Q:$D(GMTSQIT) W:FLAG>0 ! D PRNT
D SETUTL
S MDM=""
F S MDM=$O(^UTILITY($J,"GMTSMVTS",MDM)) Q:'MDM D GET
S CNTR=CNTR-1
K ^UTILITY($J)
Q
GET ; D IN5^VADPT for each mvt, print info
I ^UTILITY($J,"GMTSMVTS",MDM)=ADA Q
K VAIP
S (VAIP("E"),GMMDA)=^UTILITY($J,"GMTSMVTS",MDM) D IN5^VADPT
I $D(VAIP) D PRNT
Q
PRNT ; output line of data
S X=+$P(VAIP("MD"),U) D REGDTM4^GMTSU
D CKP^GMTSUP Q:$D(GMTSQIT)
N DOC,TYPE,CODE,SPEC,ATTN,WARD
S DOC=$E($P($G(VAIP("DR")),U,2),1,30),TYPE=$P($G(VAIP("MT")),U,2)
S CODE=+$P($G(VAIP("TT")),U),SPEC=$P(VAIP(("TS")),U,2)
S PTF=+$G(VAIP("PT"))
S TT=$S(CODE=0:"NON",CODE=1:"ADM",CODE=2:"TR ",CODE=3:"DC ",CODE=4:"CIL",CODE=5:"COL",CODE=6:"TS ",1:" ")
S GMC=1
W X,?18,TT,?23,$E(TYPE,1,56),!
I $G(DOC)'=$G(PREVDR)!($G(SPEC)'=$G(PREVSP)) D
. N AWS S AWS="Provider/Specialty: "_DOC
. W ?3,AWS,?56,SPEC,!
. S PREVDR=$G(DOC),PREVSP=$G(SPEC)
S ATTN=$P($G(VAIP("AP")),"^",2)
S WARD=$P($G(VAIP("WL")),"^",2)
I $L(ATTN),($G(ATTN)'=$G(PREVAP)!($G(WARD)'=$G(PREVWD))) D
. S AWS="Attending/Ward: "_ATTN
. W ?7,AWS,?56,WARD,!
. S PREVAP=$G(ATTN),PREVWD=$G(WARD)
D OTHER^GMTSDGC1(DFN,PTF,CODE,.VAIP,$G(GMMDA))
S FLAG=2
Q
SETUTL ; Set ^UTILITY array
S (TSDM,MDM)=0
F S TSDM=$O(^DGPM("ATS",DFN,ADA,TSDM)) Q:'TSDM D NEXT1
F S MDM=$O(^DGPM("APCA",DFN,ADA,MDM)) Q:'MDM D NEXT2
Q
NEXT1 ; Next ^UTILITY($J,"GMTSMVTS",<inverse date>) - "ATS"
S TS="",TS=$O(^DGPM("ATS",DFN,ADA,TSDM,TS)) Q:'TS
S TSDA=0,TSDA=$O(^DGPM("ATS",DFN,ADA,TSDM,TS,TSDA)) Q:'TSDA
S ^UTILITY($J,"GMTSMVTS",9999999-TSDM)=TSDA
Q
NEXT2 ; Next ^UTILITY($J,"GMTSMVTS",<date>) - "APCA"
S MDA=0,MDA=$O(^DGPM("APCA",DFN,ADA,MDM,MDA)) Q:'MDA
I MDA'=ADA S ^UTILITY($J,"GMTSMVTS",MDM)=MDA
Q
DISAB ; Disability Display
N GMW,GMTSI,VA,VADM,VAEL,VAERR,VAPA
D ELIG^VADPT I +$G(VAEL("EL")) D
. S FLAG=2
. D CKP^GMTSUP Q:$D(GMTSQIT) W "Eligibility: ",$E($P(VAEL("EL"),U,2),1,40)
. W:VAEL("ES")]"" ?56,$P(VAEL("ES"),U,2)
. D CKP^GMTSUP Q:$D(GMTSQIT) W:+VAEL("SC") !,"Total S/C %: ",$P(VAEL("SC"),U,2)
. I '$D(^DPT(DFN,.372)) D Q
. . D CKP^GMTSUP Q:$D(GMTSQIT) W !," No rated disabilities"
. S GMTSI=0
. F S GMTSI=$O(^DPT(DFN,.372,GMTSI)) Q:GMTSI'>0 D
. . N DA,DIQ,DR,DIC,GMTSDIS
. . S DIC="^DPT("_DFN_",.372,",DA=GMTSI,DR=".01;2;3",DIQ="GMTSDIS",DIQ(0)="E"
. . D EN^DIQ1
. . D CKP^GMTSUP Q:$D(GMTSQIT) W !?3,GMTSDIS(2.04,DA,.01,"E"),?51,$J(GMTSDIS(2.04,DA,2,"E"),3),"%",?60,$S(GMTSDIS(2.04,DA,3,"E")="YES":"S/C",1:"NSC")
. . D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
FADM ; Future Admissions
N GMDT,NODE,X
K ^TMP("GMFADM",$J)
D GETFADM^GMTSDGA2
Q:'$D(^TMP("GMFADM",$J))
S GMDT=0
F S GMDT=$O(^TMP("GMFADM",$J,GMDT)) Q:GMDT'>0 D
. S NODE=$G(^TMP("GMFADM",$J,GMDT))
. S X=$P(NODE,U) D REGDT4^GMTSU
. I FLAG>0 D CKP^GMTSUP Q:$D(GMTSQIT) W !
. E S FLAG=2
. D CKP^GMTSUP Q:$D(GMTSQIT) W X,?16,"Scheduled Admission",?56,$E($P(NODE,U,5),1,12),?69,$E($P(NODE,U,3),1,10),!
. D CKP^GMTSUP Q:$D(GMTSQIT)
. I $P(NODE,U,2)]"" W ?11,"Adm. Diag.: ",$P(NODE,U,2)
. I $P(NODE,U,6)>0 W ?56,"Expected LOS: ",$P(NODE,U,6),!
. D CKP^GMTSUP Q:$D(GMTSQIT)
. I $P(NODE,U,4)]"" W ?14,"Surgery: ",$P(NODE,U,4),!
K ^TMP("GMFADM",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGCH 4583 printed Dec 13, 2024@01:57:24 Page 2
GMTSDGCH ; SLC/KER/NDBI - Extended ADT Hist ; 09/21/2001
+1 ;;2.7;Health Summary;**28,35,47**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 17 ^DGPM("APCA"
+5 ; DBIA 17 ^DGPM("ATID1"
+6 ; DBIA 17 ^DGPM("ATS"
+7 ; DBIA 10035 ^DPT( fields .01,2,3 Read w/Fileman
+8 ; DBIA 2929 DSP^A7RHSM (NDBI)
+9 ; DBIA 2929 LST^A7RHSM (NDBI)
+10 ; DBIA 10015 EN^DIQ1 (file #2)
+11 ; DBIA 10061 ELIG^VADPT
+12 ; DBIA 10061 IN5^VADPT
+13 ; DBIA 10061 KVAR^VADPT
+14 ;
MAIN ; Loop through admissions starting from most recent
+1 NEW FLAG,IN,IM,ADA,ADM,MDA,MDM,X,DOC,CNTR,CODE,TYPE,TT,SPEC,ITS,TS,TSDM,TSDA,VAHOW,VA200,GMC,GMMDA,PTF
KILL VAIP
+2 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:GMTSNDM,1:100)
SET VA200=1
SET VAHOW=1
SET FLAG=-1
SET ADM=GMTS1
SET GMC=0
+3 DO DISAB
DO FADM
+4 if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO LST^A7RHSM(DFN,.A7RHS)
+5 FOR
SET ADM=$ORDER(^DGPM("ATID1",DFN,ADM))
if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO DSP^A7RHSM(ADM)
if ('ADM)!(ADM>GMTS2)!(CNTR=0)!('DFN)
QUIT
Begin DoDot:1
+6 SET GMC=0
DO MVTS
IF GMC>0
Begin DoDot:2
+7 DO ICDP^GMTSDGC2(DFN,+($GET(PTF)))
DO ICDS^GMTSDGC2(DFN,+($GET(PTF)))
End DoDot:2
End DoDot:1
+8 DO KVAR^VADPT
KILL ^UTILITY($JOB)
+9 KILL A7RHS
+10 QUIT
MVTS ; Loop through mvts chronologically, per admission
+1 SET ADA=0
SET ADA=$ORDER(^DGPM("ATID1",DFN,ADM,ADA))
if 'ADA
QUIT
+2 NEW VAIP,PREVDR,PREVSP,PREVAP,PREVWD
+3 KILL ^UTILITY($JOB)
+4 SET (VAIP("E"),GMMDA)=ADA
DO IN5^VADPT
+5 IF $DATA(VAIP)
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if FLAG>0
WRITE !
DO PRNT
+6 DO SETUTL
+7 SET MDM=""
+8 FOR
SET MDM=$ORDER(^UTILITY($JOB,"GMTSMVTS",MDM))
if 'MDM
QUIT
DO GET
+9 SET CNTR=CNTR-1
+10 KILL ^UTILITY($JOB)
+11 QUIT
GET ; D IN5^VADPT for each mvt, print info
+1 IF ^UTILITY($JOB,"GMTSMVTS",MDM)=ADA
QUIT
+2 KILL VAIP
+3 SET (VAIP("E"),GMMDA)=^UTILITY($JOB,"GMTSMVTS",MDM)
DO IN5^VADPT
+4 IF $DATA(VAIP)
DO PRNT
+5 QUIT
PRNT ; output line of data
+1 SET X=+$PIECE(VAIP("MD"),U)
DO REGDTM4^GMTSU
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+3 NEW DOC,TYPE,CODE,SPEC,ATTN,WARD
+4 SET DOC=$EXTRACT($PIECE($GET(VAIP("DR")),U,2),1,30)
SET TYPE=$PIECE($GET(VAIP("MT")),U,2)
+5 SET CODE=+$PIECE($GET(VAIP("TT")),U)
SET SPEC=$PIECE(VAIP(("TS")),U,2)
+6 SET PTF=+$GET(VAIP("PT"))
+7 SET TT=$SELECT(CODE=0:"NON",CODE=1:"ADM",CODE=2:"TR ",CODE=3:"DC ",CODE=4:"CIL",CODE=5:"COL",CODE=6:"TS ",1:" ")
+8 SET GMC=1
+9 WRITE X,?18,TT,?23,$EXTRACT(TYPE,1,56),!
+10 IF $GET(DOC)'=$GET(PREVDR)!($GET(SPEC)'=$GET(PREVSP))
Begin DoDot:1
+11 NEW AWS
SET AWS="Provider/Specialty: "_DOC
+12 WRITE ?3,AWS,?56,SPEC,!
+13 SET PREVDR=$GET(DOC)
SET PREVSP=$GET(SPEC)
End DoDot:1
+14 SET ATTN=$PIECE($GET(VAIP("AP")),"^",2)
+15 SET WARD=$PIECE($GET(VAIP("WL")),"^",2)
+16 IF $LENGTH(ATTN)
IF ($GET(ATTN)'=$GET(PREVAP)!($GET(WARD)'=$GET(PREVWD)))
Begin DoDot:1
+17 SET AWS="Attending/Ward: "_ATTN
+18 WRITE ?7,AWS,?56,WARD,!
+19 SET PREVAP=$GET(ATTN)
SET PREVWD=$GET(WARD)
End DoDot:1
+20 DO OTHER^GMTSDGC1(DFN,PTF,CODE,.VAIP,$GET(GMMDA))
+21 SET FLAG=2
+22 QUIT
SETUTL ; Set ^UTILITY array
+1 SET (TSDM,MDM)=0
+2 FOR
SET TSDM=$ORDER(^DGPM("ATS",DFN,ADA,TSDM))
if 'TSDM
QUIT
DO NEXT1
+3 FOR
SET MDM=$ORDER(^DGPM("APCA",DFN,ADA,MDM))
if 'MDM
QUIT
DO NEXT2
+4 QUIT
NEXT1 ; Next ^UTILITY($J,"GMTSMVTS",<inverse date>) - "ATS"
+1 SET TS=""
SET TS=$ORDER(^DGPM("ATS",DFN,ADA,TSDM,TS))
if 'TS
QUIT
+2 SET TSDA=0
SET TSDA=$ORDER(^DGPM("ATS",DFN,ADA,TSDM,TS,TSDA))
if 'TSDA
QUIT
+3 SET ^UTILITY($JOB,"GMTSMVTS",9999999-TSDM)=TSDA
+4 QUIT
NEXT2 ; Next ^UTILITY($J,"GMTSMVTS",<date>) - "APCA"
+1 SET MDA=0
SET MDA=$ORDER(^DGPM("APCA",DFN,ADA,MDM,MDA))
if 'MDA
QUIT
+2 IF MDA'=ADA
SET ^UTILITY($JOB,"GMTSMVTS",MDM)=MDA
+3 QUIT
DISAB ; Disability Display
+1 NEW GMW,GMTSI,VA,VADM,VAEL,VAERR,VAPA
+2 DO ELIG^VADPT
IF +$GET(VAEL("EL"))
Begin DoDot:1
+3 SET FLAG=2
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE "Eligibility: ",$EXTRACT($PIECE(VAEL("EL"),U,2),1,40)
+5 if VAEL("ES")]""
WRITE ?56,$PIECE(VAEL("ES"),U,2)
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if +VAEL("SC")
WRITE !,"Total S/C %: ",$PIECE(VAEL("SC"),U,2)
+7 IF '$DATA(^DPT(DFN,.372))
Begin DoDot:2
+8 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !," No rated disabilities"
End DoDot:2
QUIT
+9 SET GMTSI=0
+10 FOR
SET GMTSI=$ORDER(^DPT(DFN,.372,GMTSI))
if GMTSI'>0
QUIT
Begin DoDot:2
+11 NEW DA,DIQ,DR,DIC,GMTSDIS
+12 SET DIC="^DPT("_DFN_",.372,"
SET DA=GMTSI
SET DR=".01;2;3"
SET DIQ="GMTSDIS"
SET DIQ(0)="E"
+13 DO EN^DIQ1
+14 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !?3,GMTSDIS(2.04,DA,.01,"E"),?51,$JUSTIFY(GMTSDIS(2.04,DA,2,"E"),3),"%",?60,$SELECT(GMTSDIS(2.04,DA,3,"E")="YES":"S/C",1:"NSC")
+15 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
End DoDot:2
End DoDot:1
+16 QUIT
FADM ; Future Admissions
+1 NEW GMDT,NODE,X
+2 KILL ^TMP("GMFADM",$JOB)
+3 DO GETFADM^GMTSDGA2
+4 if '$DATA(^TMP("GMFADM",$JOB))
QUIT
+5 SET GMDT=0
+6 FOR
SET GMDT=$ORDER(^TMP("GMFADM",$JOB,GMDT))
if GMDT'>0
QUIT
Begin DoDot:1
+7 SET NODE=$GET(^TMP("GMFADM",$JOB,GMDT))
+8 SET X=$PIECE(NODE,U)
DO REGDT4^GMTSU
+9 IF FLAG>0
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+10 IF '$TEST
SET FLAG=2
+11 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE X,?16,"Scheduled Admission",?56,$EXTRACT($PIECE(NODE,U,5),1,12),?69,$EXTRACT($PIECE(NODE,U,3),1,10),!
+12 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+13 IF $PIECE(NODE,U,2)]""
WRITE ?11,"Adm. Diag.: ",$PIECE(NODE,U,2)
+14 IF $PIECE(NODE,U,6)>0
WRITE ?56,"Expected LOS: ",$PIECE(NODE,U,6),!
+15 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+16 IF $PIECE(NODE,U,4)]""
WRITE ?14,"Surgery: ",$PIECE(NODE,U,4),!
End DoDot:1
+17 KILL ^TMP("GMFADM",$JOB)
+18 QUIT
