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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1DGPTSUDO ;ALB/MTC - PTF UPDATE TRANSFER DRG NODE; 30 MAR 89@09 ; 3/12/02 12:14pm
2 ;;5.3;Registration;**441,510,478**;Aug 13, 1993
3 ;;ADL;Update for CSV Project;;Mar 28, 2003
4UTIL S ^UTILITY($J,"T",(9999999.999999-$E(I,1,14)))=K_"^"_$S($D(^DIC(45.7,J,0)):$P(^(0),"^",2),1:0)_"^"_X_"^^"_$P(Y,"^",8)
5 Q
6SUDO1 K ^UTILITY($J,"T"),T
7 F I=0:0 S I=$O(^DGPM("ATS",DFN,DGPMCA,I)) Q:I'>0 D
8 . S J=$O(^DGPM("ATS",DFN,DGPMCA,I,0)) I J D
9 .. S K=+$O(^(J,0)) I $D(^DGPM(K,0)) S Y=^(0),X=$S($D(^("PTF")):$P(^("PTF"),"^",2),1:"") I $D(^DGPT(PTF,"M",+X,0))!($D(^DGPM("APHY",+$P(Y,"^",14),K))) D UTIL
10 Q:'$D(^UTILITY($J,"T"))
11VARS I '$D(^UTILITY($J,"T")) G SUDO1
12 S (DGPRD,DGNXD)=$O(^UTILITY($J,"T",0)) G Q:DGPRD'>0 S T(DGPRD)=^(DGPRD),(DGEXP,DGDMS,DGTRS,DGTLOS,DGLOS,DGDAT)=0,DGPT(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),SEX=$P(^DPT(DFN,0),U,2),DOB=$P(^(0),U,3),(DGDX,DGNSV,DGPSV)=""
13 S DGDAT=$$GETDATE^ICDGTDRG(PTF)
14 K DGSURG,DGPROC S (DGSURG,DGPROC)=U
15 ;-- build DGSURG array
16 S DGPTDAT=$$GETDATE^ICDGTDRG(PTF)
17 F I=0:0 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S X=$P(^(I,0),U,8,12) D
18 . I X]"",X'="^^^^" S Y=+^(0),Y=$S('$D(DGSURG(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGSURG(Y)="" D
19 .. F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,J),DGPTDAT) I +DGPTTMP>0 S DGSURG(Y)=DGSURG(Y)_$P(X,U,J)_U
20 ;-- build DGPROC array
21 F I=0:0 S I=$O(^DGPT(PTF,"P",I)) Q:I'>0 S X=$P(^(I,0),U,5,9) D
22 . I X]"",X'="^^^^" S Y=+^(0),Y=$S('$D(DGPROC(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGPROC(Y)="" D
23 .. F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,J),DGPTDAT) I +DGPTTMP>0 S DGPROC(Y)=DGPROC(Y)_$P(X,U,J)_U
24 ;
25 I $D(^DGPT(PTF,"401P")),+DGPT(70),+DGPT(70)<2871000 S X=^("401P") I X]"",X'="^^^^" D
26 . F I=1:1:5 I $P(X,U,I)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,I),DGPTDAT) I +DGPTTMP>0 S DGPROC=DGPROC_$P(X,U,I)_U,DG401P=1
27 ;
28SUDO2 ;
29 S DGNXD=$O(^UTILITY($J,"T",DGNXD))
30 G ONE:DGNXD'>0 S T(DGNXD)=^UTILITY($J,"T",DGNXD),I1=+$P(T(DGNXD),U,3),DGDOC=$P(T(DGNXD),U,5)
31 F I=DGPRD,DGNXD S L1(I)=$P(T(I),U,2)
32 G:L1(DGPRD)=L1(DGNXD) SWCH
33 S DGPSV=$S($D(^DIC(42.4,+L1(DGPRD),0)):$P(^(0),U,3),1:""),DGNSV=$S($D(^DIC(42.4,+L1(DGNXD),0)):$P(^(0),U,3),1:"")
34 G:DGPSV']""!(DGNSV']"") SWCH
35 I "^I^SCI^B^NH^D^RE^"'[(U_DGPSV_U),$D(^DGPT(PTF,"M",I1,0)) S DGNODE=^(0) D
36 . D BLD I DGPSV'=DGNSV D DRG S DGSURG=U,DGDX="",DGLOS=0 I '$D(DG401P) S DGPROC=U
37SWCH ;
38 K DGLEV,DGPAS
39 S DGPRD=DGNXD,T(DGPRD)=T(DGNXD),(DGNSV,DGPSV)=""
40 G SUDO2
41 ;
42BLD ;
43 F I=9:-1:5 I $P(DGNODE,U,I)]"" S DGPTTMP=$$ICDDX^ICDCODE($P(DGNODE,U,I),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0 S DGDX=$P(DGNODE,U,I)_U_DGDX
44 S:$L(DGDX)>200 DGDX=$P(DGDX,U,1,30)
45 S DGLEV=$P(DGNODE,U,3),DGPAS=$P(DGNODE,U,4),X1=DGNXD,X2=DGPRD D ^%DTC S X=$S(X>0:X,1:1)-DGLEV-DGPAS,DGLOS=DGLOS+X
46 N I,J,X,Y,Z
47 F I=0:0 S I=$O(DGSURG(I)) Q:I'>0!(I\1>(DGNXD\1)) D SU
48 I '$D(DG401P) F I=0:0 S I=$O(DGPROC(I)) Q:I'>0!((I\1)>(DGNXD\1)) D ;S DGPROC=DGPROC(I)_DGPROC K DGPROC(I) I $L(DGPROC)>200 S DGPROC=$P(DGPROC,U,1,30)
49 .S X=DGPROC(I)
50 .F J=1:1:5 S Y=$P(X,U,J) Q:Y="" D
51 ..Q:$L(DGPROC)>240
52 ..S Z=U_Y_U Q:DGPROC[Z
53 ..S DGPROC=DGPROC_Y_U
54 .K DGPROC(I)
55 Q
56SU ;
57 ;S:$L(DGSURG)>200 DGSURG=$P(DGSURG,U,1,30)
58 ;I I<DGNXD S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; surgery date is prior to movement date
59 ; only gets here if surgery occurred on movement date
60 ;I DGPSV=DGNSV S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; no RAM movement occurred so surgery should be grouped
61 ;I DGPSV="S" S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; RAM movement occurred and losing service is surgery, so surgery should be grouped
62 ;Q
63 ; 2002 coding replaces above,eliminates dupes,allows more codes
64 I I<DGNXD!(DGPSV=DGNSV)!(DGPSV="S") D
65 .S X=DGSURG(I)
66 .F J=1:1:5 S Y=$P(X,U,J) Q:Y="" D
67 ..Q:$L(DGSURG)>240
68 ..S Z=U_Y_U Q:DGSURG[Z
69 ..S DGSURG=DGSURG_Y_U
70 .K DGSURG(I)
71 Q
72 ;
73DRG ;
74 S AGE=DGPRD-DOB\10000,DGTLOS=DGTLOS+DGLOS,DRG=""
75 D ^DGPTICD
76 S DGDOC=$S($D(^VA(200,+DGDOC)):DGDOC,1:"")
77 N DGFDA,DGMSG
78 S DGFDA(45.02,I1_","_PTF_",",20)=DRG
79 S DGFDA(45.02,I1_","_PTF_",",21)=DGPSV
80 S DGFDA(45.02,I1_","_PTF_",",22)=DGNXD
81 S DGFDA(45.02,I1_","_PTF_",",23)=DGLOS
82 S DGFDA(45.02,I1_","_PTF_",",24)=DGDOC
83 S DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS
84 D FILE^DIE("","DGFDA","DGMSG")
85 Q
86 ;
87ONE ;
88 S DGNXD=$S(+$P(^DGPT(PTF,"M",1,0),U,10):$P(^(0),U,10),1:DT),L1(DGNXD)=$P(^(0),U,2) S:'$D(T(DGNXD)) T(DGNXD)=T(DGPRD),DGDOC=$P(T(DGNXD),U,5)
89 S:$P(DGPT(70),U,3)>5 DGEXP=1 S:$P(DGPT(70),U,3)=4 DGDMS=1 S:$P(DGPT(70),U,13) DGTRS=1
90 I L1(DGNXD),$D(^DIC(42.4,+L1(DGNXD),0)) S I1=1,DGPSV=$P(^(0),U,3),DGADM=$P(^DGPT(PTF,0),U,2)
91 S DGNODE=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:"") D BLD
92 I $D(^DGPT("AADA",DGADM,PTF)) S I=$S($P(DGPT(70),U,10):$P(DGPT(70),U,10),$P(DGPT(70),U,11):$P(DGPT(70),U,11),1:"") I I]"" S DGDX=I_U_DGDX
93 S I1=1 D DRG,^DGPTSUD1
94Q ;
95 K DGDMS,DGDOC,DGDX,DGEXP,DGLEV,DGLOS,DGNODE,DGNSV,DGNXD,DGPAS,DGPRD,DGPROC,DGPSV,DGPT,DGSURG,DGTLOS,DGTRS,DG401P,I,I1,I2,J,L1,T,X,X1,X2,Y Q
96 ;
Note: See TracBrowser for help on using the repository browser.