- 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
