source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM8.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1PSUDEM8 ;BIR/DAM - ICD9 Codes for Inpatient PTF Record Extract ; 20 DEC 2001
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;DBIA's
5 ; Reference to file 45 supported by DBIA 3511
6 ; Reference to file 80 supported by DBIA 10082
7 ;
8EN ;EN CALLED FROM PSUDEM7
9 D PTFIEN
10 Q
11 ;
12PTFIEN ;$O through ^XTMP("PSU_"_PSUJOB,"PSUIPV" to get all the PTF IEN's
13 ;
14 S PSUC=0
15 F S PSUC=$O(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC)) Q:'PSUC D
16 .D PTF70 ;gather ICD9 data on ^DGPT(D0,70 node
17 .D PTFM ;gather ICD9 data on ^DGPT(D0,"M","AC" node
18 .D FIN K ^XTMP("PSU_"_PSUJOB,"PSUTMP3")
19 .D EN^PSUDEM9 ;gather CPT data on 2 separate ^DGPT nodes
20 Q
21 ;
22PTF70 ;Find all ICD9 pointers present on ^DGPT(D0,70 node
23 ;
24 N PSU1,PSU2,PSU3,PSU4,PSU5,PSU6,PSU7,PSU8,PSU9,PSU10,PSU11
25 S PSU1=$P($G(^DGPT(PSUC,70)),U,10) S:PSU1="" PSU1="NULL" ;Ptr 1
26 S PSU2=$P($G(^DGPT(PSUC,70)),U,16) S:PSU2="" PSU2="NULL" ;Ptr 2
27 S PSU3=$P($G(^DGPT(PSUC,70)),U,17) S:PSU3="" PSU3="NULL" ;Ptr 3
28 S PSU4=$P($G(^DGPT(PSUC,70)),U,18) S:PSU4="" PSU4="NULL" ;Ptr 4
29 S PSU5=$P($G(^DGPT(PSUC,70)),U,19) S:PSU5="" PSU5="NULL" ;Ptr 5
30 S PSU6=$P($G(^DGPT(PSUC,70)),U,20) S:PSU6="" PSU6="NULL" ;Ptr 6
31 S PSU7=$P($G(^DGPT(PSUC,70)),U,21) S:PSU7="" PSU7="NULL" ;Ptr 7
32 S PSU8=$P($G(^DGPT(PSUC,70)),U,22) S:PSU8="" PSU8="NULL" ;Ptr 8
33 S PSU9=$P($G(^DGPT(PSUC,70)),U,23) S:PSU9="" PSU9="NULL" ;Ptr 9
34 S PSU10=$P($G(^DGPT(PSUC,70)),U,24) S:PSU10="" PSU10="NULL" ;Ptr 10
35 S PSU11=$P($G(^DGPT(PSUC,70)),U,11) S:PSU11="" PSU11="NULL" ;Ptr 11
36 D ICD91
37 Q
38 ;
39ICD91 ;Find ICD9 codes from pointer on ^DGPT(D0,70 node and place in
40 ;an array
41 ;
42 N PSUID1,PSUID2,PSUID3,PSUID4,PSUID5,PSUID6,PSUID7,PSUID8,PSUID9
43 N PSUID10,PSUID11
44 S:PSU1'["N" PSUID1=$P($G(^ICD9(PSU1,0)),U) D
45 .I $D(PSUID1) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,1,PSUID1)="" ;1ST ICD9 CODE
46 S:PSU2'["N" PSUID2=$P($G(^ICD9(PSU2,0)),U) D
47 .I $D(PSUID2) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,2,PSUID2)="" ;2ND ICD9 CODE
48 S:PSU3'["N" PSUID3=$P($G(^ICD9(PSU3,0)),U) D
49 .I $D(PSUID3) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,3,PSUID3)="" ;3rd ICD9 CODE
50 S:PSU4'["N" PSUID4=$P($G(^ICD9(PSU4,0)),U) D
51 .I $D(PSUID4) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,4,PSUID4)="" ;4th ICD9 CODE
52 S:PSU5'["N" PSUID5=$P($G(^ICD9(PSU5,0)),U) D
53 .I $D(PSUID5) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,5,PSUID5)="" ;5th ICD9 CODE
54 S:PSU6'["N" PSUID6=$P($G(^ICD9(PSU6,0)),U) D
55 .I $D(PSUID6) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,6,PSUID6)="" ;6th ICD9 CODE
56 S:PSU7'["N" PSUID7=$P($G(^ICD9(PSU7,0)),U) D
57 .I $D(PSUID7) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,7,PSUID7)="" ;7th ICD9 CODE
58 S:PSU8'["N" PSUID8=$P($G(^ICD9(PSU8,0)),U) D
59 .I $D(PSUID8) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,8,PSUID8)="" ;8th ICD9 CODE
60 S:PSU9'["N" PSUID9=$P($G(^ICD9(PSU9,0)),U) D
61 .I $D(PSUID9) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,9,PSUID9)="" ;9th ICD9 CODE
62 S:PSU10'["N" PSUID10=$P($G(^ICD9(PSU10,0)),U) D
63 .I $D(PSUID10) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,10,PSUID10)="" ;10th ICD9 CODE
64 S:PSU11'["N" PSUID11=$P($G(^ICD9(PSU11,0)),U) D
65 .I $D(PSUID11) S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,11,PSUID11)="" ;11th ICD9 CODE
66 Q
67 ;
68PTFM ;
69 S PSUCD=0
70 S I=12
71 F S PSUCD=$O(^DGPT(PSUC,"M","AC",PSUCD)) Q:'PSUCD D
72 .I PSUCD="" S PSUCD="N"
73 .N PSUIDT
74 .S PSUIDT=$P($G(^ICD9(PSUCD,0)),U) D
75 ..S ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)=""
76 ..D DEL
77 ..S I=I+1
78 Q
79 ;
80DEL ;Delete duplicates
81 ;
82 F N=1:1:10 I $D(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,N,PSUIDT)) D
83 .K ^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,I,PSUIDT)
84 Q
85 ;
86FIN ;$O through array, and set codes into the Inpatient Record
87 ;global ^XTMP("PSU_"_PSUJOB,"PSUIPV"
88 ;
89 S T=0,N=8
90 F S T=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T)) Q:'T Q:N=29 D
91 .S PSUIDF=0
92 .F S PSUIDF=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP3",PSUC,T,PSUIDF)) Q:'PSUIDF D
93 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)=PSUIDF
94 ..S N=N+1
95 ;
96 F N=8:1:28 I '$P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N) D
97 .S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUC),U,N)="" ;Set unfilled pieces to null
98 Q
Note: See TracBrowser for help on using the repository browser.