GMTSDGA ; SLC/MKB,KER/NDBI - Admissions for HS ;06/25/15 15:47
;;2.7;Health Summary;**28,49,71,101,111**;Oct 20, 1995;Build 17
;
; External Reference
; ICR 5699 $$ICDDATA^ICDXCODE
; ICR 17 ^DGPM("ATID"
; ICR 1372 ^DGPT(
; ICR 2929 DSP^A7RHSM
; ICR 2929 LST^A7RHSM
; ICR 512 ^DGPMLOS
; ICR 10061 IN5^VADPT
; ICR 10061 KVAR^VADPT
;
ENAD ; Gets Admission Information
S TT=1,FLGDX=0,FLGDC=0
D PATINFO Q
ENDC ; Discharge Information
S TT=3,FLGDC=1,FLGDX=0
D PATINFO Q
ENDX ; PTF Discharge Diagnosis
S TT=3,FLGDX=1,FLGDC=0
D PATINFO Q
ENTS ; Treating Speciality Information
S TT=6,FLGDX=0,FLGDC=0
D PATINFO Q
ENTR ; Transfers
S TT=2,FLGDX=0,FLGDC=0
D PATINFO Q
PATINFO ; Patient Information
S VA200=1 K DIQ
I $D(GMTSNDM),GMTSNDM>0 S CNTR=GMTSNDM
E S CNTR=100
S GMC=-1,GMN="",ADM=GMTS1,FLAG=0
I TT=1 D FADM^GMTSDGA2
D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) LST^A7RHSM(DFN,.A7RHS)
F S ADM=$O(^DGPM("ATID"_TT,DFN,ADM)) D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) DSP^A7RHSM(ADM) Q:('ADM!(ADM>GMTS2)!($D(GMTSQIT))) D GET Q:$D(GMTSQIT)!($G(CNTR)<0)
D KILLADM K:$$NDBI^GMTSU A7RHS
Q
GET ; Admission Data
N VAHOW
S ADA=$O(^DGPM("ATID"_TT,DFN,ADM,0)) Q:'ADA
S CNTR=CNTR-1 I CNTR<0 Q
S VAIP("E")=ADA D IN5^VADPT
S (X,ADATE)=+VAIP(3) D REGDT4^GMTSU S ADT=X
K DGPMIFN S:TT=1 DGPMIFN=ADA S:TT'=1 DGPMIFN=VAIP(13)
S GMC=2
D CONTGET
S LIN=$S(TT=2:"TROUT^GMTSDGA1",FLGDX:"DXOUT^GMTSDGA1",FLGDC:"DCOUT^GMTSDGA1",TT=6:"TSOUT^GMTSDGA2",TT=1:"ADOUT^GMTSDGA1") D @LIN
K ICD(ADM)
Q
CONTGET ; ICD and LOS info only needed for certain MAS components
Q:TT=2 Q:TT=6 N ICDX,ICDI I DGPMIFN D ^DGPMLOS S LOS=+X
N GMTSDATE,GMTSTEMP,GMTSTAB S GMTSTEMP="",GMTSTAB=" "
S PTF=$S($D(VAIP(12)):VAIP(12),1:"") Q:PTF="" Q:'$D(^DGPT(PTF,70))
S ICD=^DGPT(PTF,70)
S GMTSDATE=+$P(ICD,U) I $G(GMTSDATE)="" S GMTSDATE=DT
S ICDI=+$P(ICD,U,11) I ICDI>0 D
. S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
. I $P($G(ICDX),U)=-1 D Q
.. S ICD(ADM,1,80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
.. S ICD(ADM,1,80,ICDI,3)=""
. S ICD(ADM,1,80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD(ADM,1,80,ICDI,3)=GMTSTEMP
S ICDI=+$P(ICD,U,10) I ICDI>0 D
. S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
. I $P($G(ICDX),U)=-1 D Q
.. S ICD(ADM,1,80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
.. S ICD(ADM,1,80,ICDI,3)=""
. S ICD(ADM,1,80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD(ADM,1,80,ICDI,3)=GMTSTEMP
F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D
. S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
. I $P($G(ICDX),U)=-1 D Q
.. S ICD(ADM,(GMTSI-13),80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
.. S ICD(ADM,(GMTSI-13),80,ICDI,3)=""
. S ICD(ADM,(GMTSI-13),80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD(ADM,(GMTSI-13),80,ICDI,3)=GMTSTEMP
Q:'$D(^DGPT(PTF,71))
S ICD=^DGPT(PTF,71)
F GMTSI=1:1:15 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D
. S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
. I $P($G(ICDX),U)=-1 D Q
.. S ICD(ADM,(GMTSI+11),80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
.. S ICD(ADM,(GMTSI+11),80,ICDI,3)=""
. S ICD(ADM,(GMTSI+11),80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD(ADM,(GMTSI+11),80,ICDI,3)=GMTSTEMP
Q
KILLADM ; Kill Admission variables
D KVAR^VADPT
K ADA,ADATE,ADT,BD,BDSC,DA,DIC,DDT,DP,DSPL,GMJ,GMJ1,OP,OPTR,FLAG,FLGDX,FLGDC,X,DR,GMI,GMTO,GMTNO,GMTSI,GMX,ADM,CNTR,GMC,GMZ,GMN,ICD,PTF,PTF70,PTFLG,LOS,II,DGPMIFN,IN,LIN,TI,TT,TS,SPEC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGA 3680 printed Sep 23, 2025@19:33:23 Page 2
GMTSDGA ; SLC/MKB,KER/NDBI - Admissions for HS ;06/25/15 15:47
+1 ;;2.7;Health Summary;**28,49,71,101,111**;Oct 20, 1995;Build 17
+2 ;
+3 ; External Reference
+4 ; ICR 5699 $$ICDDATA^ICDXCODE
+5 ; ICR 17 ^DGPM("ATID"
+6 ; ICR 1372 ^DGPT(
+7 ; ICR 2929 DSP^A7RHSM
+8 ; ICR 2929 LST^A7RHSM
+9 ; ICR 512 ^DGPMLOS
+10 ; ICR 10061 IN5^VADPT
+11 ; ICR 10061 KVAR^VADPT
+12 ;
ENAD ; Gets Admission Information
+1 SET TT=1
SET FLGDX=0
SET FLGDC=0
+2 DO PATINFO
QUIT
ENDC ; Discharge Information
+1 SET TT=3
SET FLGDC=1
SET FLGDX=0
+2 DO PATINFO
QUIT
ENDX ; PTF Discharge Diagnosis
+1 SET TT=3
SET FLGDX=1
SET FLGDC=0
+2 DO PATINFO
QUIT
ENTS ; Treating Speciality Information
+1 SET TT=6
SET FLGDX=0
SET FLGDC=0
+2 DO PATINFO
QUIT
ENTR ; Transfers
+1 SET TT=2
SET FLGDX=0
SET FLGDC=0
+2 DO PATINFO
QUIT
PATINFO ; Patient Information
+1 SET VA200=1
KILL DIQ
+2 IF $DATA(GMTSNDM)
IF GMTSNDM>0
SET CNTR=GMTSNDM
+3 IF '$TEST
SET CNTR=100
+4 SET GMC=-1
SET GMN=""
SET ADM=GMTS1
SET FLAG=0
+5 IF TT=1
DO FADM^GMTSDGA2
+6 if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO LST^A7RHSM(DFN,.A7RHS)
+7 FOR
SET ADM=$ORDER(^DGPM("ATID"_TT,DFN,ADM))
if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO DSP^A7RHSM(ADM)
if ('ADM!(ADM>GMTS2)!($DATA(GMTSQIT)))
QUIT
DO GET
if $DATA(GMTSQIT)!($GET(CNTR)<0)
QUIT
+8 DO KILLADM
if $$NDBI^GMTSU
KILL A7RHS
+9 QUIT
GET ; Admission Data
+1 NEW VAHOW
+2 SET ADA=$ORDER(^DGPM("ATID"_TT,DFN,ADM,0))
if 'ADA
QUIT
+3 SET CNTR=CNTR-1
IF CNTR<0
QUIT
+4 SET VAIP("E")=ADA
DO IN5^VADPT
+5 SET (X,ADATE)=+VAIP(3)
DO REGDT4^GMTSU
SET ADT=X
+6 KILL DGPMIFN
if TT=1
SET DGPMIFN=ADA
if TT'=1
SET DGPMIFN=VAIP(13)
+7 SET GMC=2
+8 DO CONTGET
+9 SET LIN=$SELECT(TT=2:"TROUT^GMTSDGA1",FLGDX:"DXOUT^GMTSDGA1",FLGDC:"DCOUT^GMTSDGA1",TT=6:"TSOUT^GMTSDGA2",TT=1:"ADOUT^GMTSDGA1")
DO @LIN
+10 KILL ICD(ADM)
+11 QUIT
CONTGET ; ICD and LOS info only needed for certain MAS components
+1 if TT=2
QUIT
if TT=6
QUIT
NEW ICDX,ICDI
IF DGPMIFN
DO ^DGPMLOS
SET LOS=+X
+2 NEW GMTSDATE,GMTSTEMP,GMTSTAB
SET GMTSTEMP=""
SET GMTSTAB=" "
+3 SET PTF=$SELECT($DATA(VAIP(12)):VAIP(12),1:"")
if PTF=""
QUIT
if '$DATA(^DGPT(PTF,70))
QUIT
+4 SET ICD=^DGPT(PTF,70)
+5 SET GMTSDATE=+$PIECE(ICD,U)
IF $GET(GMTSDATE)=""
SET GMTSDATE=DT
+6 SET ICDI=+$PIECE(ICD,U,11)
IF ICDI>0
Begin DoDot:1
+7 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+8 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+9 SET ICD(ADM,1,80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+10 SET ICD(ADM,1,80,ICDI,3)=""
End DoDot:2
QUIT
+11 SET ICD(ADM,1,80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+12 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+13 SET ICD(ADM,1,80,ICDI,3)=GMTSTEMP
End DoDot:1
+14 SET ICDI=+$PIECE(ICD,U,10)
IF ICDI>0
Begin DoDot:1
+15 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+16 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+17 SET ICD(ADM,1,80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+18 SET ICD(ADM,1,80,ICDI,3)=""
End DoDot:2
QUIT
+19 SET ICD(ADM,1,80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+20 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+21 SET ICD(ADM,1,80,ICDI,3)=GMTSTEMP
End DoDot:1
+22 FOR GMTSI=16:1:24
SET ICDI=+$PIECE(ICD,U,GMTSI)
IF ICDI>0
Begin DoDot:1
+23 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+24 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+25 SET ICD(ADM,(GMTSI-13),80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+26 SET ICD(ADM,(GMTSI-13),80,ICDI,3)=""
End DoDot:2
QUIT
+27 SET ICD(ADM,(GMTSI-13),80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+28 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+29 SET ICD(ADM,(GMTSI-13),80,ICDI,3)=GMTSTEMP
End DoDot:1
+30 if '$DATA(^DGPT(PTF,71))
QUIT
+31 SET ICD=^DGPT(PTF,71)
+32 FOR GMTSI=1:1:15
SET ICDI=+$PIECE(ICD,U,GMTSI)
IF ICDI>0
Begin DoDot:1
+33 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+34 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+35 SET ICD(ADM,(GMTSI+11),80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+36 SET ICD(ADM,(GMTSI+11),80,ICDI,3)=""
End DoDot:2
QUIT
+37 SET ICD(ADM,(GMTSI+11),80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+38 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+39 SET ICD(ADM,(GMTSI+11),80,ICDI,3)=GMTSTEMP
End DoDot:1
+40 QUIT
KILLADM ; Kill Admission variables
+1 DO KVAR^VADPT
+2 KILL ADA,ADATE,ADT,BD,BDSC,DA,DIC,DDT,DP,DSPL,GMJ,GMJ1,OP,OPTR,FLAG,FLGDX,FLGDC,X,DR,GMI,GMTO,GMTNO,GMTSI,GMX,ADM,CNTR,GMC,GMZ,GMN,ICD,PTF,PTF70,PTFLG,LOS,II,DGPMIFN,IN,LIN,TI,TT,TS,SPEC
+3 QUIT
