GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ;06/25/15 15:47
;;2.7;Health Summary;**5,35,47,71,101,111**;Oct 20, 1995;Build 17
;
; External References
; ICR 5699 $$ICDDATA^ICDXCODE
; ICR 17 ^DGPM(
; ICR 1372 ^DGPT( fields 71,73,75 Read w/Fileman
; ICR 512 ^DGPMLOS
; ICR 10015 EN^DIQ1 (file #45)
; ICR 10011 ^DIWP
;
OTHER(DFN,PTF,CODE,GMVAIP,MDA) ; Additional data to include
N LOS,ICD,DGPMIFN,GMI,GMX,NODIAG,GMTO,GMTNO,BD,BDSC,ATTN,WARD,AWS
N DP,DSPL,OP,OPTR
I CODE=1 D Q ;Other data for Admission entries
. Q:$G(GMVAIP("DN",1))'=""
. D GETDATA
. I $G(GMVAIP("MF"))]"" D CKP^GMTSUP Q:$D(GMTSQIT) W ?12,"Adm. Diag: ",GMVAIP("MF")
. W ?64,"LOS: ",LOS,!
. Q:'$D(ICD)
. S GMI=0
. F S GMI=$O(ICD(GMI)) Q:'GMI D CKP^GMTSUP Q:$D(GMTSQIT) S GMX="" F S GMX=$O(ICD(GMI,80,GMX)) Q:'GMX D NXTICD
I CODE=2 D Q ;Other data for Transfer entries
. N TRFAC
. S TRFAC=$P(^DGPM(MDA,0),U,5)
. I $P($G(GMVAIP("WL")),U,2)]"" D CKP^GMTSUP Q:$D(GMTSQIT) W ?19,$S($P(VAIP("MT"),U,2)'["TO":"To ",1:""),$P(VAIP("WL"),U,2),$S($L(TRFAC):" at "_TRFAC,1:""),!
I CODE=3 D Q ;Other data for Discharge entries
. ; Discharge data
. D GETDATA
. D CKP^GMTSUP Q:$D(GMTSQIT) W ?11,"Bedsection: ",BDSC,?64,"LOS: ",LOS,!
. S NODIAG=1,GMI=0
. F S GMI=$O(ICD(GMI)) Q:GMI'>0 S GMX=0 F S GMX=$O(ICD(GMI,80,GMX)) Q:GMX'>0 D NXTICD
. I NODIAG D CKP^GMTSUP Q:$D(GMTSQIT) D
. . W ?7,"Principal Diag: No discharge diagnosis available.",!
. D CKP^GMTSUP Q:$D(GMTSQIT) W ?4,"Disposition Place: ",DSPL,!
. D CKP^GMTSUP Q:$D(GMTSQIT) W ?4,"Outpat. Treatment: ",OPTR,!
. I 'GMTSNPG D CKP^GMTSUP Q:$D(GMTSQIT) W !
I CODE=6 D Q ;Other data for Treating Specialty entries
. N DIWL,DIWF,DIWR,GMJ,GMJ1
. K ^UTILITY($J,"W")
. S DIWL=22,DIWR=78,DIWF="C56"
. I $D(^DGPM(MDA,"DX")) D
. . F GMJ=1:1:$P(^DGPM(MDA,"DX",0),"^",4) S X=^DGPM(MDA,"DX",GMJ,0) D ^DIWP
. I $D(^UTILITY($J,"W")) D
. . S GMJ=$O(^UTILITY($J,"W",0)) Q:'GMJ
. . D CKP^GMTSUP Q:$D(GMTSQIT) W ?14,"TS Diag: "
. . S GMJ1=0
. . F S GMJ1=$O(^UTILITY($J,"W",GMJ,GMJ1)) Q:'GMJ1 D CKP^GMTSUP Q:$D(GMTSQIT) W ?23,^UTILITY($J,"W",GMJ,GMJ1,0),!
. K ^UTILITY($J,"W")
Q
GETDATA ; Gets LOS, ICD and bedsection data
N DIC,DR,DA,DIQ,GMTSI,X,PTFA,GMTSDATE,ICDI,ICDX,GMTSTEMP,GMTSTAB
S DGPMIFN=$G(GMVAIP("AN")),GMTSTAB=" "
I DGPMIFN D ^DGPMLOS S LOS=+X
I '$D(^DGPT(PTF,70)) D Q
. S (BDSC,DSPL,OPTR)="UNKNOWN"
S DIC=45,DA=+PTF,DR="71;73;75;",DIQ="PTFA(" D EN^DIQ1
S BDSC=$S(PTFA(45,+DA,71)]"":PTFA(45,+DA,71),1:"UNKNOWN")
S OPTR=$S(PTFA(45,+DA,73)]"":PTFA(45,+DA,73),1:"UNKNOWN")
S DSPL=$S(PTFA(45,+DA,75)]"":PTFA(45,+DA,75),1:"UNKNOWN")
S ICD=^DGPT(PTF,70),DIC=80,DR=".01;3"
S GMTSDATE=$P(ICD,U) I $G(GMTSDATE)="" S GMTSDATE=DT
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(1,80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
. . S ICD(1,80,ICDI,3)=""
. S ICD(1,80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD(1,80,ICDI,3)=GMTSTEMP
S ICDI=+$P(ICD,U,11) Q:+ICDI'>0
S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
I $P($G(ICDX),U)=-1 D Q
. S ICD(2,80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
. S ICD(2,80,ICDI,3)=""
S ICD(2,80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
S ICD(2,80,ICDI,3)=GMTSTEMP
F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D ;secondary diagnoses from 70 node
. S ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
. I $P($G(ICDX),U)=-1 D Q
. . S ICD((GMTSI-13),80,ICDI,.01)=$J(" ",38)_$P($G(ICDX),"^",2)
. . S ICD((GMTSI-13),80,ICDI,3)=""
. S ICD((GMTSI-13),80,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
. S GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
. S ICD((GMTSI-13),80,ICDI,3)=GMTSTEMP
Q:'$D(^DGPT(PTF,71))
S ICD=ICD_U_^DGPT(PTF,71)
F GMTSI=1:1:15 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D ;secondary diagnoses from 71 node
. 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
NXTICD ; Print the next ICD
S (GMTO,GMTNO)="" S GMTO=$G(ICD(GMI,80,GMX,3)),GMTNO=$G(ICD(GMI,80,GMX,.01))
W:GMI=1 ?7,"Principal Diag: "
W:GMI=2 ?17,"DXLS: "
W:GMI=3 ?15,"ICD DX: "
D CKP^GMTSUP Q:$D(GMTSQIT) W ?23,GMTO,?61,GMTNO,!
S NODIAG=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGC1 4617 printed Sep 23, 2025@19:33:26 Page 2
GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ;06/25/15 15:47
+1 ;;2.7;Health Summary;**5,35,47,71,101,111**;Oct 20, 1995;Build 17
+2 ;
+3 ; External References
+4 ; ICR 5699 $$ICDDATA^ICDXCODE
+5 ; ICR 17 ^DGPM(
+6 ; ICR 1372 ^DGPT( fields 71,73,75 Read w/Fileman
+7 ; ICR 512 ^DGPMLOS
+8 ; ICR 10015 EN^DIQ1 (file #45)
+9 ; ICR 10011 ^DIWP
+10 ;
OTHER(DFN,PTF,CODE,GMVAIP,MDA) ; Additional data to include
+1 NEW LOS,ICD,DGPMIFN,GMI,GMX,NODIAG,GMTO,GMTNO,BD,BDSC,ATTN,WARD,AWS
+2 NEW DP,DSPL,OP,OPTR
+3 ;Other data for Admission entries
IF CODE=1
Begin DoDot:1
+4 if $GET(GMVAIP("DN",1))'=""
QUIT
+5 DO GETDATA
+6 IF $GET(GMVAIP("MF"))]""
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?12,"Adm. Diag: ",GMVAIP("MF")
+7 WRITE ?64,"LOS: ",LOS,!
+8 if '$DATA(ICD)
QUIT
+9 SET GMI=0
+10 FOR
SET GMI=$ORDER(ICD(GMI))
if 'GMI
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
SET GMX=""
FOR
SET GMX=$ORDER(ICD(GMI,80,GMX))
if 'GMX
QUIT
DO NXTICD
End DoDot:1
QUIT
+11 ;Other data for Transfer entries
IF CODE=2
Begin DoDot:1
+12 NEW TRFAC
+13 SET TRFAC=$PIECE(^DGPM(MDA,0),U,5)
+14 IF $PIECE($GET(GMVAIP("WL")),U,2)]""
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?19,$SELECT($PIECE(VAIP("MT"),U,2)'["TO":"To ",1:""),$PIECE(VAIP("WL"),U,2),$SELECT($LENGTH(TRFAC):" at "_TRFAC,1:""),!
End DoDot:1
QUIT
+15 ;Other data for Discharge entries
IF CODE=3
Begin DoDot:1
+16 ; Discharge data
+17 DO GETDATA
+18 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?11,"Bedsection: ",BDSC,?64,"LOS: ",LOS,!
+19 SET NODIAG=1
SET GMI=0
+20 FOR
SET GMI=$ORDER(ICD(GMI))
if GMI'>0
QUIT
SET GMX=0
FOR
SET GMX=$ORDER(ICD(GMI,80,GMX))
if GMX'>0
QUIT
DO NXTICD
+21 IF NODIAG
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
Begin DoDot:2
+22 WRITE ?7,"Principal Diag: No discharge diagnosis available.",!
End DoDot:2
+23 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?4,"Disposition Place: ",DSPL,!
+24 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?4,"Outpat. Treatment: ",OPTR,!
+25 IF 'GMTSNPG
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
End DoDot:1
QUIT
+26 ;Other data for Treating Specialty entries
IF CODE=6
Begin DoDot:1
+27 NEW DIWL,DIWF,DIWR,GMJ,GMJ1
+28 KILL ^UTILITY($JOB,"W")
+29 SET DIWL=22
SET DIWR=78
SET DIWF="C56"
+30 IF $DATA(^DGPM(MDA,"DX"))
Begin DoDot:2
+31 FOR GMJ=1:1:$PIECE(^DGPM(MDA,"DX",0),"^",4)
SET X=^DGPM(MDA,"DX",GMJ,0)
DO ^DIWP
End DoDot:2
+32 IF $DATA(^UTILITY($JOB,"W"))
Begin DoDot:2
+33 SET GMJ=$ORDER(^UTILITY($JOB,"W",0))
if 'GMJ
QUIT
+34 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?14,"TS Diag: "
+35 SET GMJ1=0
+36 FOR
SET GMJ1=$ORDER(^UTILITY($JOB,"W",GMJ,GMJ1))
if 'GMJ1
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?23,^UTILITY($JOB,"W",GMJ,GMJ1,0),!
End DoDot:2
+37 KILL ^UTILITY($JOB,"W")
End DoDot:1
QUIT
+38 QUIT
GETDATA ; Gets LOS, ICD and bedsection data
+1 NEW DIC,DR,DA,DIQ,GMTSI,X,PTFA,GMTSDATE,ICDI,ICDX,GMTSTEMP,GMTSTAB
+2 SET DGPMIFN=$GET(GMVAIP("AN"))
SET GMTSTAB=" "
+3 IF DGPMIFN
DO ^DGPMLOS
SET LOS=+X
+4 IF '$DATA(^DGPT(PTF,70))
Begin DoDot:1
+5 SET (BDSC,DSPL,OPTR)="UNKNOWN"
End DoDot:1
QUIT
+6 SET DIC=45
SET DA=+PTF
SET DR="71;73;75;"
SET DIQ="PTFA("
DO EN^DIQ1
+7 SET BDSC=$SELECT(PTFA(45,+DA,71)]"":PTFA(45,+DA,71),1:"UNKNOWN")
+8 SET OPTR=$SELECT(PTFA(45,+DA,73)]"":PTFA(45,+DA,73),1:"UNKNOWN")
+9 SET DSPL=$SELECT(PTFA(45,+DA,75)]"":PTFA(45,+DA,75),1:"UNKNOWN")
+10 SET ICD=^DGPT(PTF,70)
SET DIC=80
SET DR=".01;3"
+11 SET GMTSDATE=$PIECE(ICD,U)
IF $GET(GMTSDATE)=""
SET GMTSDATE=DT
+12 SET ICDI=+$PIECE(ICD,U,10)
IF +ICDI>0
Begin DoDot:1
+13 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+14 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+15 SET ICD(1,80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+16 SET ICD(1,80,ICDI,3)=""
End DoDot:2
QUIT
+17 SET ICD(1,80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+18 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+19 SET ICD(1,80,ICDI,3)=GMTSTEMP
End DoDot:1
+20 SET ICDI=+$PIECE(ICD,U,11)
if +ICDI'>0
QUIT
+21 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+22 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:1
+23 SET ICD(2,80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+24 SET ICD(2,80,ICDI,3)=""
End DoDot:1
QUIT
+25 SET ICD(2,80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+26 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+27 SET ICD(2,80,ICDI,3)=GMTSTEMP
+28 ;secondary diagnoses from 70 node
FOR GMTSI=16:1:24
SET ICDI=+$PIECE(ICD,U,GMTSI)
IF ICDI>0
Begin DoDot:1
+29 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+30 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+31 SET ICD((GMTSI-13),80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+32 SET ICD((GMTSI-13),80,ICDI,3)=""
End DoDot:2
QUIT
+33 SET ICD((GMTSI-13),80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+34 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+35 SET ICD((GMTSI-13),80,ICDI,3)=GMTSTEMP
End DoDot:1
+36 if '$DATA(^DGPT(PTF,71))
QUIT
+37 SET ICD=ICD_U_^DGPT(PTF,71)
+38 ;secondary diagnoses from 71 node
FOR GMTSI=1:1:15
SET ICDI=+$PIECE(ICD,U,GMTSI)
IF ICDI>0
Begin DoDot:1
+39 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80)
+40 IF $PIECE($GET(ICDX),U)=-1
Begin DoDot:2
+41 SET ICD(ADM,(GMTSI+11),80,ICDI,.01)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
+42 SET ICD(ADM,(GMTSI+11),80,ICDI,3)=""
End DoDot:2
QUIT
+43 SET ICD(ADM,(GMTSI+11),80,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+44 SET GMTSTEMP=$$VLT^ICDEX(80,ICDI,GMTSDATE)
+45 SET ICD(ADM,(GMTSI+11),80,ICDI,3)=GMTSTEMP
End DoDot:1
+46 QUIT
NXTICD ; Print the next ICD
+1 SET (GMTO,GMTNO)=""
SET GMTO=$GET(ICD(GMI,80,GMX,3))
SET GMTNO=$GET(ICD(GMI,80,GMX,.01))
+2 if GMI=1
WRITE ?7,"Principal Diag: "
+3 if GMI=2
WRITE ?17,"DXLS: "
+4 if GMI=3
WRITE ?15,"ICD DX: "
+5 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?23,GMTO,?61,GMTNO,!
+6 SET NODIAG=0
+7 QUIT
