GMTSDGH ; SLC/MKB,KER/NDBI - Patient Hist by admissions ; 02/27/2002
;;2.7;Health Summary;**28,49**;Oct 20, 1995
;
; External References
; DBIA 17 ^DGPM("APCA"
; DBIA 17 ^DGPM("ATID1"
; DBIA 17 ^DGPM("ATS"
; DBIA 2929 DSP^A7RHSM
; DBIA 2929 LST^A7RHSM
; DBIA 10061 IN5^VADPT
; DBIA 10061 KVAR^VADPT
;
MAIN ; Loop through admissions starting from most recent
N VAHOW
K VAIP
I $D(GMTSNDM),GMTSNDM>0 S CNTR=GMTSNDM
E S CNTR=100
S VA200=1,VAHOW=1,FLAG=-1,ADM=GMTS1
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 MVTS
D KILVAR K:$$NDBI^GMTSU A7RHS
Q
MVTS ; Loop through mvts chronologically, per admission
S ADA=0,ADA=$O(^DGPM("ATID1",DFN,ADM,ADA)) Q:'ADA
K VAIP,PREVDR,PREVSP,^UTILITY($J)
S VAIP("E")=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
Q
GET ; Get Inpatient Data [v5.0 and above]
I ^UTILITY($J,"GMTSMVTS",MDM)=ADA Q
K VAIP S VAIP("E")=^UTILITY($J,"GMTSMVTS",MDM) D IN5^VADPT
I $D(VAIP) D PRNT
Q
PRNT ; Output Data
S X=+$P(VAIP("MD"),U) D REGDT4^GMTSU
D CKP^GMTSUP Q:$D(GMTSQIT)
S DOC=$E($P(VAIP("DR"),U,2),1,10),TYPE=$P(VAIP("MT"),U,2),CODE=+$P(VAIP("TT"),U),SPEC=$E($P(VAIP("TS"),U,2),1,12)
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:" ")
I 'GMTSNPG,$D(PREVDR),PREVDR=$P(VAIP("DR"),U) S DOC=" "" "
I 'GMTSNPG,$D(PREVSP),PREVSP=$P(VAIP("TS"),U) S SPEC=" "" "
W X,?12,TT," ",$E(TYPE,1,34),?55,SPEC,?69,DOC,!
S FLAG=2,PREVDR=$P(VAIP("DR"),U),PREVSP=$P(VAIP("TS"),U)
Q
SETUTL ; Get Treating Specialty and Corresponding Admission
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 ; Treating Specialty (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 ; Corresponding Admission (APCA)
S MDA=0,MDA=$O(^DGPM("APCA",DFN,ADA,MDM,MDA)) Q:'MDA
I MDA'=ADA S ^UTILITY($J,"GMTSMVTS",MDM)=MDA
Q
KILVAR ; Clean-up, exit
D KVAR^VADPT
K FLAG,IN,IM,ADA,ADM,MDA,MDM,X,DOC,CNTR,CODE,TYPE,TT,PREVSP,PREVDR,SPEC
K ITS,TS,TSDM,TSDA,^UTILITY($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGH 2556 printed Dec 13, 2024@01:57:26 Page 2
GMTSDGH ; SLC/MKB,KER/NDBI - Patient Hist by admissions ; 02/27/2002
+1 ;;2.7;Health Summary;**28,49**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 17 ^DGPM("APCA"
+5 ; DBIA 17 ^DGPM("ATID1"
+6 ; DBIA 17 ^DGPM("ATS"
+7 ; DBIA 2929 DSP^A7RHSM
+8 ; DBIA 2929 LST^A7RHSM
+9 ; DBIA 10061 IN5^VADPT
+10 ; DBIA 10061 KVAR^VADPT
+11 ;
MAIN ; Loop through admissions starting from most recent
+1 NEW VAHOW
+2 KILL VAIP
+3 IF $DATA(GMTSNDM)
IF GMTSNDM>0
SET CNTR=GMTSNDM
+4 IF '$TEST
SET CNTR=100
+5 SET VA200=1
SET VAHOW=1
SET FLAG=-1
SET ADM=GMTS1
+6 if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO LST^A7RHSM(DFN,.A7RHS)
+7 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
DO MVTS
+8 DO KILVAR
if $$NDBI^GMTSU
KILL A7RHS
+9 QUIT
MVTS ; Loop through mvts chronologically, per admission
+1 SET ADA=0
SET ADA=$ORDER(^DGPM("ATID1",DFN,ADM,ADA))
if 'ADA
QUIT
+2 KILL VAIP,PREVDR,PREVSP,^UTILITY($JOB)
+3 SET VAIP("E")=ADA
DO IN5^VADPT
+4 IF $DATA(VAIP)
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if FLAG>0
WRITE !
DO PRNT
+5 DO SETUTL
+6 SET MDM=""
FOR
SET MDM=$ORDER(^UTILITY($JOB,"GMTSMVTS",MDM))
if 'MDM
QUIT
DO GET
+7 SET CNTR=CNTR-1
+8 QUIT
GET ; Get Inpatient Data [v5.0 and above]
+1 IF ^UTILITY($JOB,"GMTSMVTS",MDM)=ADA
QUIT
+2 KILL VAIP
SET VAIP("E")=^UTILITY($JOB,"GMTSMVTS",MDM)
DO IN5^VADPT
+3 IF $DATA(VAIP)
DO PRNT
+4 QUIT
PRNT ; Output Data
+1 SET X=+$PIECE(VAIP("MD"),U)
DO REGDT4^GMTSU
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+3 SET DOC=$EXTRACT($PIECE(VAIP("DR"),U,2),1,10)
SET TYPE=$PIECE(VAIP("MT"),U,2)
SET CODE=+$PIECE(VAIP("TT"),U)
SET SPEC=$EXTRACT($PIECE(VAIP("TS"),U,2),1,12)
+4 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:" ")
+5 IF 'GMTSNPG
IF $DATA(PREVDR)
IF PREVDR=$PIECE(VAIP("DR"),U)
SET DOC=" "" "
+6 IF 'GMTSNPG
IF $DATA(PREVSP)
IF PREVSP=$PIECE(VAIP("TS"),U)
SET SPEC=" "" "
+7 WRITE X,?12,TT," ",$EXTRACT(TYPE,1,34),?55,SPEC,?69,DOC,!
+8 SET FLAG=2
SET PREVDR=$PIECE(VAIP("DR"),U)
SET PREVSP=$PIECE(VAIP("TS"),U)
+9 QUIT
SETUTL ; Get Treating Specialty and Corresponding Admission
+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 ; Treating Specialty (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 ; Corresponding Admission (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
KILVAR ; Clean-up, exit
+1 DO KVAR^VADPT
+2 KILL FLAG,IN,IM,ADA,ADM,MDA,MDM,X,DOC,CNTR,CODE,TYPE,TT,PREVSP,PREVDR,SPEC
+3 KILL ITS,TS,TSDM,TSDA,^UTILITY($JOB)
+4 QUIT
