GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ; 03/24/2004 [8/25/04 9:59am]
;;2.7;Health Summary;**5,35,47,71**;Oct 20, 1995
;
; External References
; DBIA 3390 $$ICDDX^ICDCODE
; DBIA 17 ^DGPM(
; DBIA 1372 ^DGPT( fields 71,73,75 Read w/Fileman
; DBIA 512 ^DGPMLOS
; DBIA 10015 EN^DIQ1 (file #45)
; DBIA 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
S DGPMIFN=$G(GMVAIP("AN"))
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")
Q:'$D(^ICD9)
S ICD=^DGPT(PTF,70),DIC=80,DR=".01;3"
S ICDI=+$P(ICD,U,10) I +ICDI>0 D
. S ICDX=$$ICDDX^ICDCODE(ICDI)
. S ICD(1,80,ICDI,.01)=$P(ICDX,"^",2)
. S ICD(1,80,ICDI,3)=$P(ICDX,"^",4)
S ICDI=+$P(ICD,U,11) Q:+ICDI'>0
S ICDX=$$ICDDX^ICDCODE(ICDI)
S ICD(2,80,ICDI,.01)=$P(ICDX,"^",2)
S ICD(2,80,ICDI,3)=$P(ICDX,"^",4)
F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D
. S ICDX=$$ICDDX^ICDCODE(ICDI)
. S ICD((GMTSI-13),80,ICDI,.01)=$P(ICDX,"^",2)
. S ICD((GMTSI-13),80,ICDI,3)=$P(ICDX,"^",4)
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,?69,GMTNO,!
S NODIAG=0
Q
GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ; 03/24/2004 [8/25/04 9:59am]
+1 ;;2.7;Health Summary;**5,35,47,71**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 3390 $$ICDDX^ICDCODE
+5 ; DBIA 17 ^DGPM(
+6 ; DBIA 1372 ^DGPT( fields 71,73,75 Read w/Fileman
+7 ; DBIA 512 ^DGPMLOS
+8 ; DBIA 10015 EN^DIQ1 (file #45)
+9 ; DBIA 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
+2 SET DGPMIFN=$GET(GMVAIP("AN"))
+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 IF '$DATA(^ICD9)
QUIT
+11 SET ICD=^DGPT(PTF,70)
SET DIC=80
SET DR=".01;3"
+12 SET ICDI=+$PIECE(ICD,U,10)
IF +ICDI>0
Begin DoDot:1
+13 SET ICDX=$$ICDDX^ICDCODE(ICDI)
+14 SET ICD(1,80,ICDI,.01)=$PIECE(ICDX,"^",2)
+15 SET ICD(1,80,ICDI,3)=$PIECE(ICDX,"^",4)
End DoDot:1
+16 SET ICDI=+$PIECE(ICD,U,11)
IF +ICDI'>0
QUIT
+17 SET ICDX=$$ICDDX^ICDCODE(ICDI)
+18 SET ICD(2,80,ICDI,.01)=$PIECE(ICDX,"^",2)
+19 SET ICD(2,80,ICDI,3)=$PIECE(ICDX,"^",4)
+20 FOR GMTSI=16:1:24
SET ICDI=+$PIECE(ICD,U,GMTSI)
IF ICDI>0
Begin DoDot:1
+21 SET ICDX=$$ICDDX^ICDCODE(ICDI)
+22 SET ICD((GMTSI-13),80,ICDI,.01)=$PIECE(ICDX,"^",2)
+23 SET ICD((GMTSI-13),80,ICDI,3)=$PIECE(ICDX,"^",4)
End DoDot:1
+24 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,?69,GMTNO,!
+6 SET NODIAG=0
+7 QUIT
