source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPXAPI.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1TIUPXAPI ; SLC/JER - Interface w/PCE/Visit Tracking ;5/8/03@10:26
2 ;;1.0;TEXT INTEGRATION UTILITIES;**15,24,29,82,107,126,161**;Jun 20, 1997
3CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate
4 N CPT,ICD,ICDARR,CPTARR,SC,DTOUT,TIUOK,TIUPRLST
5 ; For Historical Visits, just QUEUE the PXAPI call and quit
6 I $P(TIU("VSTR"),";",3)="E" D QUE^TIUPXAP1 Q
7 ; If no Location, and not Historical Visit, then quit
8 Q:+$G(TIU("VSTR"))'>0
9REENTER I $G(VALMAR)="^TMP(""TIUR"",$J)",$D(TIU("PNM")) D
10 . W !!,"For ",$G(TIU("PNM"))," ",$G(TIU("PID"))," Visit on "
11 . W $P($G(TIU("EDT")),U,2),"..."
12 D PROVLIST(.TIUPRLST)
13 N TIUVDT S TIUVDT=$P($G(TIU("VSTR")),";",2)
14 ; *161 Pass encounter date to GETICD as 3rd and 4th variable, then to IBDF18A
15 D GETICD(TIU("LOC"),.ICDARR,TIUVDT)
16ICDCALL D ICD(.ICD,.ICDARR,TIUVDT) G:+$G(DTOUT) INSUFF ; **15**
17 I '$D(ICD),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Diagnoses." H 3 G ICDCALL
18 K ICDARR ; **15**
19 ; Pass encounter date to TIUPXAPC to pass to IBDF18A **161**
20 D GETCPT^TIUPXAPC(TIU("LOC"),.CPTARR,TIUVDT)
21 ; Pass encounter date to TIUPXAPC,ICPTCOD,TIUPXAPM for CSV **161**
22CPTCALL D CPT^TIUPXAPC(.CPT,.CPTARR,TIUVDT) G:+$G(DTOUT) INSUFF
23 I '$D(CPT),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Procedures." H 3 G CPTCALL
24 K CPTARR ; **15**
25 D SCASK^TIUPXAPS(.SC,+DFN,.TIU)
26INSUFF I $D(DTOUT)!(+$O(ICD(0))'>0)&(+$O(CPT(0))'>0)&(+$O(SC(0))'>0) D G POST
27 . W !,$C(7),"Insufficient information for Workload Credit."
28 . W !,"Missing information will have to be captured by another method."
29 S TIUOK=$$CONFIRM(.ICD,.CPT,.SC)
30 I '+TIUOK D G REENTER
31 . W !!,"Changes Discarded. Please Enter Corrected Workload Data..." H 3
32 . K ICD,CPT,SC,ICDARR,CPTARR
33 K CPTARR,ICDARR
34 W !!,"Posting Workload Credit..."
35POST D QUE^TIUPXAP1 ; Queue TIU/PXAPI RESOURCE
36 W:'+$G(DTOUT) "Done."
37 Q
38CONFIRM(ICD,CPT,SC) ; Show user and confirm
39 N TIUI,TIUY S TIUY=0
40 W !!,"You have indicated the following data apply to this visit:",!
41 W !,"DIAGNOSES:"
42 S TIUI=0
43 F S TIUI=$O(ICD(TIUI)) Q:+TIUI'>0 D
44 . W !?3,$P(ICD(TIUI),U,2),?12,$E($P(ICD(TIUI),U,3),1,67)
45 . W:+$G(ICD(TIUI,"PRIMARY")) " <<< PRIMARY"
46 W !!,"PROCEDURES:"
47 S TIUI=0
48 F S TIUI=$O(CPT(TIUI)) Q:+TIUI'>0 D
49 . W !?3,$P(CPT(TIUI),U,4),?12,$E($P(CPT(TIUI),U,2),1,67)
50 . ;Display CPT Modifiers
51 . D DISMOD^TIUPXAPM(.CPT,TIUI)
52 I $D(SC)>9 D
53 . W !!,"SERVICE CONNECTION:"
54 . W !?3,"Service Connected? ",$S(+$G(SC("SC")):"YES",1:"NO")
55 . I $D(SC("AO")),+$G(SC("SC"))'>0 W !?3,"Agent Orange? ",$S($G(SC("AO"))]"":$P($G(SC("AO")),U,2),1:"NOT ANSWERED")
56 . I $D(SC("IR")),+$G(SC("SC"))'>0 W !?3,"Ionizing Radiation? ",$S($G(SC("IR"))]"":$P($G(SC("IR")),U,2),1:"NOT ANSWERED")
57 . I $D(SC("EC")),+$G(SC("SC"))'>0 W !?3,"Environmental Contaminants? ",$S($G(SC("EC"))]"":$P($G(SC("EC")),U,2),1:"NOT ANSWERED")
58 . I $D(SC("MST")) W !?3,"MST? ",$S($G(SC("MST"))]"":$P($G(SC("MST")),U,2),1:"NOT ANSWERED")
59 . I $D(SC("HNC")) W !?3,"Head and/or Neck Cancer? ",$S($G(SC("HNC"))]"":$P($G(SC("HNC")),U,2),1:"NOT ANSWERED")
60 W ! S TIUY=+$$READ^TIUU("Y"," ...OK","YES")
61 Q +$G(TIUY)
62 ; Pass encounter date to GETICD to pass to IBDF18A **161**
63GETICD(TIULOC,ICDARR,TIUVDT) ; Get ICD-9 codes for clinic
64 N TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT S TIUCAT=""
65 ; Pass encounter date as the 5th parameter to IBDF18A **161**
66 D GETLST^IBDF18A(+TIULOC,"DG SELECT ICD-9 DIAGNOSIS CODES","ARRY2",,,,TIUVDT)
67 S (TIUI,TIUROW,TIUITM)=0,(TIUCOL,TIUPAGE)=1
68 F S TIUI=$O(ARRY2(TIUI)) Q:+TIUI'>0 D
69 . I $P(ARRY2(TIUI),U)]"" D I 1
70 . . S TIUROW=+$G(TIUROW)+1,TIUITM=+$G(TIUITM)+1
71 . . S ICDARR(TIUROW,TIUCOL)=TIUITM_U_$G(ARRY2(TIUI))_U_TIUCAT
72 . . S ICDARR("INDEX",TIUITM)=$G(ARRY2(TIUI))_U_TIUCAT K ARRY2(TIUI)
73 . E D
74 . . S TIUROW=+$G(TIUROW)+1,TIUCAT=$$UP^XLFSTR($P($G(ARRY2(TIUI)),U,2))
75 . . S ICDARR(TIUROW,TIUCOL)=U_U_TIUCAT
76 . . K ARRY2(TIUI)
77 . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1
78 . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)
79 I +$G(ARRY2(0))>0 D
80 . S TIUROW=+$G(TIUROW)+1,TIUITM=TIUITM+1
81 . S ICDARR(TIUROW,TIUCOL)=TIUITM_"^OTHER ICD^OTHER Diagnosis"
82 . S ICDARR("INDEX",TIUITM)="OTHER ICD^OTHER Diagnosis"
83 . S ICDARR(0)=+$G(ARRY2(0))_U_+$G(TIUROW)_U_+$G(TIUPAGE)
84 . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1
85 . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)
86 Q
87 ; Pass encounter date as TIUVDT for CSV **161**
88ICD(ICD,ICDARR,TIUVDT) ; Select Dx's
89 N I,J,Y,TIUICD,TIUICNT,TIUPGS,TIUPG,TIUITM,TIULITM,TIUPNM
90 S TIUPNM=$S($L($G(TIU("PNM"))):$G(TIU("PNM")),+$G(DFN):$$PTNAME^TIULC1(DFN),1:"the Patient")
91 W !!,"Please Indicate the Diagnoses for which "_TIUPNM_" was Seen:"
92 W:+$O(ICDARR(0)) !
93 S TIUICNT=+$G(ICDARR(0)),TIUPGS=$P($G(ICDARR(0)),U,3)
94 S (I,J,L,Y)=0 I +TIUICNT S TIUPG=1
95 F S I=$O(ICDARR(I)) Q:+I'>0 D Q:+$G(DTOUT)
96 . S J=0 W ! F S J=$O(ICDARR(I,J)) Q:+J'>0 D
97 . . W ?((J-1)*25) W:+$P(ICDARR(I,J),U) $J($P(ICDARR(I,J),U),2)_" " W $E($P(ICDARR(I,J),U,3),1,20)
98 . . S TIUITM=$S(+$G(ICDARR(I,J)):+$G(ICDARR(I,J)),1:$G(TIUITM))
99 . . S:TIUITM>+$G(TIULITM) TIULITM=TIUITM
100 . I I#20=0 S Y=$S(+Y:Y,1:"")_$P($$PICK^TIUPXAP2(1,+$G(TIULITM),"Select Diagnoses"_$S(+$G(TIUPG)<TIUPGS:" (<RETURN> to see next page of choices)",1:"")),U),TIUPG=+$G(TIUPG)+1 W !
101 . S L=I S:TIUITM>+$G(TIULITM) TIULITM=TIUITM
102 I +$G(DTOUT) Q
103 I L#20 S Y=$S(+Y:Y,1:"")_$P($$PICK^TIUPXAP2(1,TIULITM,"Select Diagnoses"),U)
104 I +Y,$P(ICDARR("INDEX",+Y),U)'="OTHER ICD" D I 1
105 . N I,ITEM F I=1:1:($L(Y,",")-1) D Q:+$G(DTOUT)
106 . . S ITEM=$P(Y,",",I)
107 . . I $P(ICDARR("INDEX",+ITEM),U)'="OTHER ICD" D
108 . . . S TIUICD=+$O(^ICD9("AB",$P(ICDARR("INDEX",+ITEM),U)_" ",0))
109 . . . S ICD(I)=TIUICD_U_$G(ICDARR("INDEX",+ITEM))
110 . . ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
111 . . E D ICDOUT(.ICD,.I,TIUVDT)
112 Q:+$G(DTOUT)
113 ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
114 E D ICDOUT(.ICD,,TIUVDT)
115 I +$O(ICD(1)) D ASKPRMRY(.ICD) I 1
116 Q:+$G(DTOUT)
117 E I $D(ICD(1)) S ICD(1,"PRIMARY")=1
118 Q
119ASKPRMRY(ICD) ; Which Dx is Primary
120 N I,L,Y
121PRMAGN W !!,"Please indicate which of the Diagnoses is the Primary Diagnosis:",!
122 S (I,L,Y)=0 F S I=$O(ICD(I)) Q:+I'>0!+Y D
123 . W:$P(ICD(I),U)]"" !,I,?7,$P(ICD(I),U,3)
124 . I I#20=0 S Y=$P($$PICK^TIUPXAP2(1,I,"Select Diagnosis","NO"),U)
125 . S L=I
126 I L#20,'+Y S Y=$P($$PICK^TIUPXAP2(1,L,"Select Diagnosis","NO"),U)
127 I +Y'>0 W !!?3,$C(7),"You must specify a Primary Diagnosis." G PRMAGN
128 I +Y,$D(ICD(+Y)) S ICD(+Y,"PRIMARY")=1
129 Q
130ICDOUT(ICD,TIUI,TIUVDT) ; Go off-list for Dx
131 N DIC,X,Y,TIUICD,TIUOUT
132 F D Q:+$G(TIUOUT)
133 . I $L($T(CONFIG^LEXSET)) D I 1
134 . . ; Pass encounter date to LEXSET for CSV **161**
135 . . D CONFIG^LEXSET("ICD","ICD",TIUVDT)
136 . E D Q
137 . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!
138 . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
139 . . S TIUOUT=1
140 . S DIC(0)="AEMQ"
141 . S DIC("A")="Select "_$S(+$G(ICDARR(0))'>0:"Diagnosis: ",1:"Another Diagnosis"_$S($D(ICDARR):" (NOT from Above List)",1:"")_": ")
142 . N X K DIC("B")
143 . D ^DIC
144 . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q
145 . I $G(Y(1))]"" D Q
146 . . S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))
147 . . S:TIUICD'>0 TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_"0 ",0))
148 . . I +TIUICD'>0 W !,$C(7),"ICD CODE NOT FOUND FOR EXPRESSION." Q
149 . . S:$S(+$G(TIUI)'>0:1,$D(ICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1
150 . . S ICD(TIUI)=TIUICD_U_Y(1)_U_$P(Y,U,2)
151 . W $C(7),!!,"Nothing found for ",X,"..."
152 . F D Q:(+Y>0)!+$G(TIUOUT)
153 . . N X
154 . . I $L($T(CONFIG^LEXSET)) D I 1
155 . . . ; Pass encounter date to LEXSET for CSV **161**
156 . . . D CONFIG^LEXSET("ICD","ICD",TIUVDT)
157 . . E D Q
158 . . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!
159 . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
160 . . . S TIUOUT=1
161 . . S DIC("A")="Please try another expression, or RETURN to continue: "
162 . . D ^DIC
163 . . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q
164 . . I +$G(Y(1))>0 D Q
165 . . . S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))
166 . . . S:$S(+$G(TIUI)'>0:1,$D(ICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1
167 . . . S ICD(TIUI)=TIUICD_U_Y(1)_U_$P(Y,U,2)
168 . . W $C(7),!!,"Nothing found for ",X,"..."
169 Q
170PROVLIST(PROVLIST) ; Identify primary provider
171 N PRIMARY,DFLT,DUOUT S DFLT=""
172 W !
173 I +$P($G(TIUPRM0),U,8)=0 Q
174 I +$P($G(TIUPRM0),U,8)=1 S DFLT=$$DFLTDOC(+TIU("VLOC"))
175 I +DFLT=DUZ S PROVLIST(1,"NAME")=DUZ,PROVLIST(1,"PRIMARY")=1 Q
176 I +DFLT S DFLT=$P(DFLT,U,2)
177 S:DFLT']"" DFLT=$S($$PROVIDER^TIUPXAP1(DUZ,DT):$$PERSNAME^TIULC1(DUZ),1:"")
178ASKPR S PRIMARY=+$$ASKDOC(DFLT)
179 I +PRIMARY'>0 Q
180 I '+$$PROVIDER^TIUPXAP1(PRIMARY,DT) D G ASKPR
181 . W !,$C(7)," Selected user is not a known PROVIDER. Please choose another..."
182 S PROVLIST(1,"NAME")=DUZ
183 I PRIMARY=DUZ S PROVLIST(1,"PRIMARY")=1
184 E S PROVLIST(2,"NAME")=PRIMARY,PROVLIST(2,"PRIMARY")=1,PROVLIST(1,"PRIMARY")=0
185 Q
186ASKDOC(DFLT) ; Call ^DIC to look-up provider
187 N DIC,X,Y
188 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select PRIMARY PROVIDER: "
189 I $G(DFLT)]"" S DIC("B")=$G(DFLT)
190 D ^DIC
191 Q +Y
192DFLTDOC(HLOC) ; Get the default Provider
193 N PXBPMT,TIUPNM,Y S Y=""
194 D PRV^PXBUTL2(HLOC)
195 I $D(PXBPMT("DEF")) S TIUPNM=$O(PXBPMT("DEF","")),Y=$O(PXBPMT("DEF",TIUPNM,0))_U_TIUPNM
196 Q Y
Note: See TracBrowser for help on using the repository browser.