source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXADOFS.m@ 794

Last change on this file since 794 was 645, checked in by Sam Habiel, 15 years ago

Initial Import of BMX.net code

File size: 6.6 KB
Line 
1BMXADOFS ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
2 ;;2.1;BMX;;Jul 26, 2009
3 ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
4 ; CONTAINS SPECIAL CODE RELATED TO FILING PROPLEMS, POVS, FAMILY HX, PERSONAL HX AND NOTES.
5 ;
6 ;
7 ;
8PAT ; TEST PROBLEM ADD
9 S DATA=".01|`8257"_$C(30)_".02|`53"_$C(30)_".03|"_DT_$C(30)_".05|C-POX"_$C(30)_".06|`4585"_$C(30)_".12|I"_$C(30,31)
10 D FILE^BMXADOF(.XXX,9000011,"",DATA) W !,XXX K XXX,DATA Q
11 ;
12PET ; TEST PROB EDIT
13 S DATA=".01|250.00"_$C(30)_".03|"_DT_$C(30)_".05|HI MOM"_$C(30)_".12|I"_$C(30,31)
14 D FILE^BMXADOF(.XXX,9000011,"1757",DATA) W !,XXX K XXX,DATA Q
15 ;
16TDP ; TEST PROBLEM DELETE
17 S DATA=$C(31)
18 D FILE^BMXADOF(.XXX,9000011,"-1757",DATA) W !,XXX K XXX,DATA Q
19 ;
20TPOV ; ADD POV TEST
21 S DATA=".01|`8718"_$C(30)_".02|`53"_$C(30)_".03|`3909"_$C(30)_".04|DM---I"_$C(30)_".12|P"_$C(30,31)
22 D FILE^BMXADOF(.XXX,9000010.07,"",DATA) W !,XXX K XXX,DATA Q
23 ;
24TH ; HX TEST
25 S DATA=".01|250.00"_$C(30)_".02|`53"_$C(30)_".03|JUL 15,2004"_$C(30)_".04|FAMILY HX OF LUNG CA"_$C(30,31)
26 D FILE^BMXADOF(.XXX,9000014,"",DATA) W !,XXX K XXX,DATA Q
27 ;
28TNOTE ; TEST ADDING A NOTE TO A PROBLEM
29 N DATA,XXX,PROBIEN,FACNIEN,FACIEN,DAS
30 S PROBIEN=3,FACIEN=4587
31 S FACNIEN=$$FACNIEN(PROBIEN,FACIEN) ; YOU MUST SPECIFY THE PROBLEM IEN AND THE FACILITY IEN
32 S DAS=PROBIEN_","_FACNIEN_","
33 S DATA=".03|NEW NOTE #2"_$C(30,31) ; THE DATA STRING JUST CONTAINS THE NOTE FIELD.
34 ; THE OTHER FIELDS (INCLUDING .01) ARE ADDED BY BMXADOF
35 D FILE^BMXADOF(.XXX,9000011.1111,DAS,DATA) W !,XXX
36 Q
37 ;
38 ; -----------------------------------------------------------------------------------------------------
39 ;
40SPEC(FILE,DATA,UFLG) ;EP - SPECIAL DATA MODS FOR SPECIFIC FILES
41 I FILE=9000010.07 S DATA=$$POV(DATA) Q DATA
42 I FILE=9000011 S DATA=$$PROB(DATA,$G(UFLG)) Q DATA
43 I FILE=9000013!(FILE=9000014) S DATA=$$HX(DATA) Q DATA
44 I FILE=9000011.1111 S DATA=$$NOTE(DATA,$G(DAS(2)),$G(DAS(1))) Q DATA
45 ; I FILE=9000010.18,DATA'["|.04|" G DSTG
46 Q DATA
47 ;
48HX(DATA) ; INPUT STRING TRANSFORM FOR PHX AND FHX
49 N NARR,NIEN,%,A,B,X,Y,%DT
50 I DATA[".01|`" G HNARR
51 S DATA=$$ICD(DATA,.01) I DATA="" Q ""
52HNARR I DATA'[".04|'" G HDT
53 S DATA=$$NARR(DATA,.04)
54HDT I DATA'[".03|" Q DATA
55 S X=+$P(DATA,".03|",2) I X?7N Q DATA
56 S %DT="" D ^%DT
57 I Y'?7N Q DATA
58 S A=$P(DATA,".03|")
59 S B=$P(DATA,".03|",2) S B=$P(B,$C(30),2)
60 S DATA=A_".03|"_Y
61 I $L(B) S DATA=DATA_$C(30)_B
62 Q DATA
63 ;
64POV(DATA) ; POV INPUT STRING TRANSFORM
65 N NARR,NIEN,%
66 I DATA[".01|`" G PVNARR
67 S DATA=$$ICD(DATA,.01) I DATA="" Q ""
68PVNARR I DATA'[".04|'" Q DATA
69 S DATA=$$NARR(DATA,.04)
70 Q DATA
71 ;
72PROB(DATA,UFLG) ; PROBLEM LIST INPUT STRING TRANSFORM
73 N NARR,NIEN,%,PNUM,FACIEN,DFN,X,A,B
74PNARR I DATA'[".05|" G PICD
75 S %=$P(DATA,".05|",2)
76 S NARR=$P(%,$C(30))
77 I NARR'?1"`"1.N S DATA=$$NARR(DATA,.05) ; STUFF THE NARR LOOKUP VALUE IN THE DATA STRING
78 I '$L(DATA) Q ""
79PICD S %=$P(DATA,"|") I %'=.01,DATA'[($C(30)_".01|") G PNUM
80 S DATA=$$ICD(DATA,.01) I DATA="" Q ""
81PNUM I $G(UFLG)="E" Q DATA ; STOP HERE IF IN EDIT MODE
82 I $P(DATA,($C(30)_".07|"),2) G TODAY ; GET NEXT PROB NUM
83 S DFN=+$P(DATA,".02|`",2)
84 I 'DFN S DATA="" Q ""
85 S FACIEN=+$P(DATA,".06|`",2)
86 I 'FACIEN Q ""
87 S PNUM=$$NEXTPBN(DFN,FACIEN)
88 I 'PNUM Q ""
89 S X=$L(DATA,$C(30))
90 S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
91 S DATA=A_$C(30)_".07|"_PNUM_$C(30)_B
92TODAY I $P(DATA,($C(30)_".08|"),2) Q DATA ; GET TODAY'S DATE
93 S X=$L(DATA,$C(30))
94 S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
95 S DATA=A_$C(30)_".08|"_$G(DT)_$C(30)_B
96 Q DATA
97 ;
98NOTE(DATA,PIEN,FNIEN) ; GIVEN A DATA STRING CONTAINING THE NOTE, THE PROBLEM IEN, AND THE FAC-NOTE IEN:
99 ; ADD NOTE # AND STATUS TO THE DATA STRING
100 I $G(DATA)'[".03|" Q ""
101 I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
102 N NUM
103 I DATA'[".04|" S DATA=".04|A"_$C(30)_DATA
104 I DATA'[".01|" D
105 . S NUM=$$NEXTNOTE(PIEN,FNIEN)
106 . I 'NUM Q
107 . S DATA=".01|"_NUM_$C(30)_DATA
108 Q DATA
109 ;
110TI N XXX S XXX=$$ICD(".01|250.00"_$C(30)_".02|123"_$C(30)_".03|ABC",.01) W !,$TR(XXX,$C(30),"{") Q
111ICD(DATA,FLD) ; VERIFY ICD CODE AND GET LOOKUP VALUE
112 I '$G(FLD) Q ""
113 I '$L($G(DATA)) Q ""
114 N %,A,B
115 S %=$P(DATA,"|")
116 I %=FLD D Q DATA
117 . S %=$P(DATA,"|",2)
118 . S %=$P(%,$C(30))
119 . I %?1"`"1.N Q
120 . S %=$O(^ICD9("BA",%_" ",0))
121 . I '% S DATA="" Q
122 . S A=$P(DATA,"|")
123 . S B=$P(DATA,"|",2,999)
124 . S B=$P(B,$C(30),2,999)
125 . S DATA=A_"|`"_%
126 . I $L(B) S DATA=DATA_$C(30)_B
127 . Q
128 S %=$P(DATA,($C(30)_FLD_"|"),2) D
129 . S %=$P(%,$C(30))
130 . I %?1"`"1.N Q DATA
131 . S %=$O(^ICD9("BA",%_" ",0))
132 . I '% S DATA="" Q
133 . S A=$P(DATA,($C(30)_FLD_"|"))
134 . S B=$P(DATA,($C(30)_FLD_"|"),2,999)
135 . S B=$P(B,$C(30),2,999)
136 . S DATA=A_$C(30)_FLD_"|`"_%
137 . I $L(B) S DATA=DATA_$C(30)_B
138 . Q
139 Q DATA
140 ;
141NARR(DATA,FLD) ; SUBSTITUTE A LOOKUP VALUE FOR NARRATIVE DATA IN THE DATA STRING
142 N A,B,C,X,Y,DIC,Z
143 I '$G(FLD) Q ""
144 I '$L($G(DATA)) Q ""
145 S Z=FLD_"|"
146 S A=$P(DATA,Z)
147 S B=$P(DATA,Z,2)
148 S NARR=$P(B,$C(30))
149 S NARR=$$UP^XLFSTR(NARR) ; CONVERT ALL NARRATIVE TO UPPERCASE
150 S C=$P(B,$C(30),2,999)
151 S DIC="^AUTNPOV(",DIC(0)="L",X=NARR
152 D ^DIC I Y=-1 Q ""
153 S DATA=A_FLD_"|`"_+Y
154 I $L(C) S DATA=DATA_$C(30)_C
155 D ^XBFMK
156 Q DATA
157 ;
158FACNIEN(PIEN,FIEN) ; GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN
159 I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
160 I '$D(^DIC(4,+$G(FIEN),0)) Q ""
161 N FNIEN
162 S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT
163 ; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE
164 S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1
165 S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN
166 S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^"
167 S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)=""
168 Q FNIEN
169 ;
170NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY
171 N MAX,PIEN,X,Y
172 S MAX=0,PIEN=0
173 F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT
174 . S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
175 . I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY
176 . S Y=$P(X,U,7)
177 . I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR
178 . Q
179 S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER
180 Q MAX
181 ;
182NN W $$NEXTNOTE(3,1) Q
183NEXTNOTE(PIEN,FNIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY-NOTE IEN
184 I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
185 N MAX,NIEN,X,Y
186 S MAX=0,NIEN=0
187 F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D
188 . S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q
189 . S Y=+X
190 . I Y>MAX S MAX=Y
191 . Q
192 S MAX=MAX+1
193 Q MAX
194 ;
195PIENN(PIEN) ; GIVEN A PROBLEM IEN, RETURN PROBLEM NARRATIVE (ICD)
196 N X,IIEN,NIEN,NARR,ICD
197 S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
198 S IIEN=$P(X,U) I 'IIEN Q ""
199 S NIEN=$P(X,U,5) I 'NIEN Q ""
200 S ICD=$P($G(^ICD9(IIEN,0)),U) I '$L(ICD) Q ""
201 S NARR=$P($G(^AUTNPOV(NIEN,0)),U) I '$L(NARR) Q ""
202 S X=NARR_" ("_ICD_")"
203 Q X
204 ;
Note: See TracBrowser for help on using the repository browser.