source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSDGC1.m@ 846

Last change on this file since 846 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ; 03/24/2004 [8/25/04 9:59am]
2 ;;2.7;Health Summary;**5,35,47,71**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 3390 $$ICDDX^ICDCODE
6 ; DBIA 17 ^DGPM(
7 ; DBIA 1372 ^DGPT( fields 71,73,75 Read w/Fileman
8 ; DBIA 512 ^DGPMLOS
9 ; DBIA 10015 EN^DIQ1 (file #45)
10 ; DBIA 10011 ^DIWP
11 ;
12OTHER(DFN,PTF,CODE,GMVAIP,MDA) ; Additional data to include
13 N LOS,ICD,DGPMIFN,GMI,GMX,NODIAG,GMTO,GMTNO,BD,BDSC,ATTN,WARD,AWS
14 N DP,DSPL,OP,OPTR
15 I CODE=1 D Q ;Other data for Admission entries
16 . Q:$G(GMVAIP("DN",1))'=""
17 . D GETDATA
18 . I $G(GMVAIP("MF"))]"" D CKP^GMTSUP Q:$D(GMTSQIT) W ?12,"Adm. Diag: ",GMVAIP("MF")
19 . W ?64,"LOS: ",LOS,!
20 . Q:'$D(ICD)
21 . S GMI=0
22 . 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
23 I CODE=2 D Q ;Other data for Transfer entries
24 . N TRFAC
25 . S TRFAC=$P(^DGPM(MDA,0),U,5)
26 . 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:""),!
27 I CODE=3 D Q ;Other data for Discharge entries
28 . ; Discharge data
29 . D GETDATA
30 . D CKP^GMTSUP Q:$D(GMTSQIT) W ?11,"Bedsection: ",BDSC,?64,"LOS: ",LOS,!
31 . S NODIAG=1,GMI=0
32 . 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
33 . I NODIAG D CKP^GMTSUP Q:$D(GMTSQIT) D
34 . . W ?7,"Principal Diag: No discharge diagnosis available.",!
35 . D CKP^GMTSUP Q:$D(GMTSQIT) W ?4,"Disposition Place: ",DSPL,!
36 . D CKP^GMTSUP Q:$D(GMTSQIT) W ?4,"Outpat. Treatment: ",OPTR,!
37 . I 'GMTSNPG D CKP^GMTSUP Q:$D(GMTSQIT) W !
38 I CODE=6 D Q ;Other data for Treating Specialty entries
39 . N DIWL,DIWF,DIWR,GMJ,GMJ1
40 . K ^UTILITY($J,"W")
41 . S DIWL=22,DIWR=78,DIWF="C56"
42 . I $D(^DGPM(MDA,"DX")) D
43 . . F GMJ=1:1:$P(^DGPM(MDA,"DX",0),"^",4) S X=^DGPM(MDA,"DX",GMJ,0) D ^DIWP
44 . I $D(^UTILITY($J,"W")) D
45 . . S GMJ=$O(^UTILITY($J,"W",0)) Q:'GMJ
46 . . D CKP^GMTSUP Q:$D(GMTSQIT) W ?14,"TS Diag: "
47 . . S GMJ1=0
48 . . 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),!
49 . K ^UTILITY($J,"W")
50 Q
51GETDATA ; Gets LOS, ICD and bedsection data
52 N DIC,DR,DA,DIQ,GMTSI,X,PTFA
53 S DGPMIFN=$G(GMVAIP("AN"))
54 I DGPMIFN D ^DGPMLOS S LOS=+X
55 I '$D(^DGPT(PTF,70)) D Q
56 . S (BDSC,DSPL,OPTR)="UNKNOWN"
57 S DIC=45,DA=+PTF,DR="71;73;75;",DIQ="PTFA(" D EN^DIQ1
58 S BDSC=$S(PTFA(45,+DA,71)]"":PTFA(45,+DA,71),1:"UNKNOWN")
59 S OPTR=$S(PTFA(45,+DA,73)]"":PTFA(45,+DA,73),1:"UNKNOWN")
60 S DSPL=$S(PTFA(45,+DA,75)]"":PTFA(45,+DA,75),1:"UNKNOWN")
61 Q:'$D(^ICD9)
62 S ICD=^DGPT(PTF,70),DIC=80,DR=".01;3"
63 S ICDI=+$P(ICD,U,10) I +ICDI>0 D
64 . S ICDX=$$ICDDX^ICDCODE(ICDI)
65 . S ICD(1,80,ICDI,.01)=$P(ICDX,"^",2)
66 . S ICD(1,80,ICDI,3)=$P(ICDX,"^",4)
67 S ICDI=+$P(ICD,U,11) Q:+ICDI'>0
68 S ICDX=$$ICDDX^ICDCODE(ICDI)
69 S ICD(2,80,ICDI,.01)=$P(ICDX,"^",2)
70 S ICD(2,80,ICDI,3)=$P(ICDX,"^",4)
71 F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D
72 . S ICDX=$$ICDDX^ICDCODE(ICDI)
73 . S ICD((GMTSI-13),80,ICDI,.01)=$P(ICDX,"^",2)
74 . S ICD((GMTSI-13),80,ICDI,3)=$P(ICDX,"^",4)
75 Q
76NXTICD ; Print the next ICD
77 S (GMTO,GMTNO)="" S GMTO=$G(ICD(GMI,80,GMX,3)),GMTNO=$G(ICD(GMI,80,GMX,.01))
78 W:GMI=1 ?7,"Principal Diag: "
79 W:GMI=2 ?17,"DXLS: "
80 W:GMI=3 ?15,"ICD DX: "
81 D CKP^GMTSUP Q:$D(GMTSQIT) W ?23,GMTO,?69,GMTNO,!
82 S NODIAG=0
83 Q
Note: See TracBrowser for help on using the repository browser.