source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFD.m@ 1141

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

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1DGPTFD ;ALB/MTC/ADL - Sets Required Variables for DRG on 701 Screen ; 2/19/02 12:52pm
2 ;;5.3;Registration;**60,441,510**;Aug 13, 1993
3 ;;ADL;Update for CSV Project;;Mar 24, 2003
4 ;
5EN1 ;-- entry point from 701
6 Q:'$D(^DGPT(PTF,70)) S DGPT(70)=^(70)
7 ;
8 ;-- check for DXLS
9 I $P(DGPT(70),U,10)="",$P(DGPT(70),U,11)="" G Q
10 ;-- did patient die during care
11 S DGEXP=$S($P(DGPT(70),U,3)>5:1,1:0)
12 ;-- discharged against med advice
13 S DGDMS=$S($P(DGPT(70),U,3)=4:1,1:0)
14 ;-- transfer to acute care facility
15 S DGTRS=$S($P(DGPT(70),U,13):1,1:0)
16 ;-- sex,age
17 S SEX=$P(^DPT(DFN,0),U,2),AGE=$S(+DGPT(70):+DGPT(70),1:DT)-$P(^(0),U,3)\10000,DOB=$P(^(0),U,3) ; DOB added by abr for ICD calc.
18 S DGDAT=$$GETDATE^ICDGTDRG(PTF)
19 ;-- build diagnosis string
20 S DGDX=""
21 ;-- new record after 10/1/86
22 I '+DGPT(70)!(+DGPT(70)>2861000) F DGI=16:1:24 I $P(DGPT(70),U,DGI)]"" S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT(70),U,DGI),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGDX=DGDX_U_$P(DGPT(70),U,DGI)
23 ;-- old record format
24 I +DGPT(70),+DGPT(70)<2861000 F DGI=0:0 S DGI=$O(^DGPT(PTF,"M","AM",DGI)) Q:DGI'>0 S DGJ=$O(^DGPT(PTF,"M","AM",DGI,0)) I $D(^DGPT(PTF,"M",+DGJ,0)) S DGNODE=$P(^(0),U,5,9) I DGNODE'="^^^^" D OLD
25 S DGDX=$S($P(DGPT(70),U,10):$P(DGPT(70),"^",10),1:$P(DGPT(70),U,11))_DGDX
26 ;-- build surgery and procedure strings
27 K DGSURG,DGPROC
28 ;-- start with surgeries (401)
29 F DGI=0:0 S DGI=$O(^DGPT(PTF,"S",DGI)) Q:DGI'>0 S X=$P(^(DGI,0),U,8,12) I X]"",X'="^^^^" S K=+^(0),K=$S('$D(DGSURG(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGSURG(K)="" S DGVAR=0 D TAG
30 ;-- build DGSURG
31 N I,X,Y,Z ; eliminate duplicates as we go
32 I $D(DGSURG) S DGSURG=U F DGI=0:0 S DGI=$O(DGSURG(DGI)) Q:DGI'>0 D
33 .S X=DGSURG(DGI)
34 .F I=1:1:5 S Y=$P(X,U,I) Q:Y="" D
35 ..Q:$L(DGSURG)>240
36 ..S Z=U_Y_U Q:DGSURG[Z
37 ..S DGSURG=DGSURG_Y_U
38 ;-- procedures next old records before 10/1/87
39 I +DGPT(70),+DGPT(70)<2871000 G DRG:'$D(^DGPT(PTF,"401P")) S DGPROC="",X=^("401P") D:X]""&(X'="^^^^") G DRG
40 . F DGI=1:1:5 I $P(X,U,DGI)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,DGI),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGPROC=DGPROC_$P(X,U,DGI)_U
41 ;-- get 601 (procedures)
42 F DGI=0:0 S DGI=$O(^DGPT(PTF,"P",DGI)) Q:DGI'>0 S X=$P(^(DGI,0),U,5,9) I X]"",X'="^^^^" S K=+^(0),K=$S('$D(DGPROC(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGPROC(K)="" S DGVAR=1 D TAG
43 ;-- build DGPROC and eliminate duplicates as we go
44 I $D(DGPROC) S DGPROC=U F DGI=0:0 S DGI=$O(DGPROC(DGI)) Q:DGI'>0 D
45 .S X=DGPROC(DGI)
46 .F I=1:1:5 S Y=$P(X,U,I) Q:Y="" D
47 ..Q:$L(DGPROC)>240
48 ..S Z=U_Y_U Q:DGPROC[Z
49 ..S DGPROC=DGPROC_Y_U
50DRG ;
51 S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD ;return DRG code even if inactive
52 ;
53Q K AGE,SEX,DGEXP,DGDMS,DGPT,DGTRS,DGDX,DGNODE,DGPROC,DGSURG,DGDRGPRT,DGI,DGJ,K,DOB Q
54 ;
55OLD ;-- used to format diagnostic codes for old PTF records
56 S X="" F DGJ=1:1:5 I $P(DGNODE,"^",DGJ)]"",$D(^ICD9($P(DGNODE,"^",DGJ),0)) S X=X_"^"_$P(DGNODE,"^",DGJ)
57 S DGDX=X_$P(DGDX,"^",1,40)
58 Q
59TAG ;-- used to build sur/proc string date
60 F DGJ=1:1:5 I $P(X,U,DGJ)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,DGJ),$P(DGPT(70),".")) I +DGPTTMP>0,$P(DGPTTMP,U,10) S:DGVAR=0 DGSURG(K)=DGSURG(K)_$P(X,U,DGJ)_U S:DGVAR=1 DGPROC(K)=DGPROC(K)_$P(X,U,DGJ)_U
61 Q
Note: See TracBrowser for help on using the repository browser.