- 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
- 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">GET">GET">GET">GET">GET">GET">GET(DOC)'=$GET">GET">GET">GET">GET">GET">GET">GET(PREVDR)!($GET">GET">GET">GET">GET">GET">GET">GET(SPEC)'=$GET">GET">GET">GET">GET">GET">GET">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">GET">GET">GET">GET">GET">GET">GET(ATTN)'=$GET">GET">GET">GET">GET">GET">GET">GET(PREVAP)!($GET">GET">GET">GET">GET">GET">GET">GET(WARD)'=$GET">GET">GET">GET">GET">GET">GET">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
