| 1 | DGPTFD ;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 | ;
|
|---|
| 5 | EN1 ;-- 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
|
|---|
| 50 | DRG ;
|
|---|
| 51 | S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD ;return DRG code even if inactive
|
|---|
| 52 | ;
|
|---|
| 53 | Q K AGE,SEX,DGEXP,DGDMS,DGPT,DGTRS,DGDX,DGNODE,DGPROC,DGSURG,DGDRGPRT,DGI,DGJ,K,DOB Q
|
|---|
| 54 | ;
|
|---|
| 55 | OLD ;-- 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
|
|---|
| 59 | TAG ;-- 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
|
|---|
