source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRCAPPH1.m@ 1193

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1LRCAPPH1 ;DALOI/SED/RKS/KLL - PROCESS PHLEBOTOMY WORKLOAD DATA CONT ;07/30/04
2 ;;5.2;LAB SERVICE;**127,136,138,158,263,264,274,291,359,308**;Sep 27, 1994
3 ; Reference to ^SC( Supported by DBIA #1482
4 ; Reference to $$CODM^ICPTCOD Supported by DBIA #1995-A
5 ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
6 ; Reference to $$DATA2PCE^PXAPI Supported by DBIA #1889-A
7 ; Reference to $$DELVFILE^PXAPI Supported by DBIA #1889-B
8 ; Reference to ENCEVENT^PXKENC Supported by DBIA #1889-F
9 ; Reference to $$NOW^XLFDT Supported by Reference #10103
10 ; Reference to $$GET^XUA4A72 Supported by Reference #1625
11EN3 ;LREDT = PATIENT ENCOUNTER DATE
12 N LREDT,LRNOP,LRBEID
13 K ^TMP("LRPXAPI",$J),LRXTST,LRVSITN,LRXCPT
14NP ;Not perform entry
15 S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=""
16 S LREDT=$P($G(^LRO(69,LRCDT,1,LRSN,1)),U)
17 N LRDUZ
18 Q:+LREDT'>0!('$D(^LR(+NODE,0))#2)
19 S:$G(LRDBUG) LREDT=$$NOW^XLFDT
20 S EDATE=$P(LREDT,".")
21 S:'$P(LREDT,".",2) $P(LREDT,".",2)="1201"
22 S LOC=+$P(NODE,U,9),LRNINS=$P(NODE(1),U,8),LRPRO=+$P(NODE,U,6) ;CHECK
23 S LRDUZ=+$P(NODE,U,2)
24 S LRNINS=$S($P($G(^SC(LOC,0)),U,4):$P(^(0),U,4),$G(LRNINS):LRNINS,1:LRINS)
25 S LRPRO=$S($$GET^XUA4A72(LRPRO,EDATE)>0:LRPRO,1:LRDPRAC)
26 I $S('$G(LOC):1,"CMZ"'[$P($G(^SC(LOC,0)),U,3):1,1:0) Q
27 I $S('DFN:1,'LOC:1,1:0) S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=1 S LRNOP=1 Q
28 I 'LRNINS S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=2 S LRNOP=2 Q
29 I 'LRPRO S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=3 S LRNOP=3 Q
30 Q:$G(LRNP)
31EN5 ;GET THE CPT CODES FOR THE TESTS
32 I LRCDT,LRSN,$D(^LRO(69,LRCDT,1,LRSN,2,0)) D
33 . S (LRTST,LRCNT,LRXAA)=0 K LRXTST S LRXTST=""
34 . F S LRTST=$O(^LRO(69,LRCDT,1,LRSN,2,LRTST)) Q:+LRTST'>0 D
35 . . Q:'($D(^LRO(69,LRCDT,1,LRSN,2,LRTST,0))#2) S LREN5=^(0)
36 . . Q:$S($P(LREN5,U,12):1,$P(LREN5,U,11):1,1:0) ;Don't send cancel/already sent codes
37 . . S LRTSTP=+$P(LREN5,U),LRAA=+$P(LREN5,U,4) Q:$S('LRTSTP:1,'LRAA:1,1:0)
38 . . ;Turn off old style PCE reporting for CH subscripts.
39 . . ;Data passed via Billing Aware API
40 . . I $P($G(^LRO(68,LRAA,0)),U,2)="CH" Q
41 . . S LRBEID=$P(^LRO(69,LRCDT,1,LRSN,2,LRTST,.3),U)
42 . . I '$G(LRDBUG),$P($G(^LRO(68,LRAA,0)),U,2)'="MI" S $P(^LRO(69,LRCDT,1,LRSN,2,LRTST,0),U,12)=1
43 . . I 'LRXAA S LRXAA=LRAA D LOC
44 . . Q:'$G(LRDSSID)
45 . . I LRXAA'=LRAA,$D(^TMP("LRPXAPI",$J,"PROCEDURE")) D SEND K ^TMP("LRPXAPI",$J) S LRXAA=LRAA D LOC Q:'$G(LRDSSID) D EN6 Q
46 . . D EN6
47 I $D(^TMP("LRPXAPI",$J,"PROCEDURE")),'$G(^LRO(69,"AA",LRCEX,LROA)) D SEND
48END Q:$G(LRDBUG)
49END0 K ^TMP("LRPXAPI",$J),LRINA,LRREL,LRNLT,CPT,LRPRO,LRICPT,EDATE,LRTST
50 K I,LOC,LRI,LRCNT,LRSTP,LRNINS,LROK,LRAA,LRXAA,LRDSSID,LREN5,LRXTST
51 K LRNLTN,LRIDT,LRXTSTU,LRXCPT
52 Q
53EN6 ;Called from LRCAPPNP
54 ;Turn off old style PCE reporting for CH subscripts.
55 ;Data passed via Billing Aware API
56 I $G(LRAA),$P($G(^LRO(68,LRAA,0)),U,2)="CH" Q
57 S:'$D(^LRO(69,LRCDT,1,LRSN,"PCE")) ^("PCE")=""
58 N LRFLG
59 S LRNLT=+$P($G(^LAB(60,LRTSTP,64)),U),LRICPT=0
60 Q:+LRNLT'>0
61 Q:'$D(^LAM("AD",LRNLT,"CPT")) S LRNLTN=$P(^LAM(LRNLT,0),U,2)
62 Q:'LRNLTN
63 F S LRICPT=$O(^LAM("AD",LRNLT,"CPT",LRICPT)) Q:+LRICPT'>0 S CPT=+$P($G(^LAM(LRNLT,4,LRICPT,0)),U) I CPT,$P(^(0),U,2)="CPT" D
64 . ;CPT must be active in file #64 before edit can continue against #81
65 . S LRFLG=1
66 . S LRREL=$P(^LAM(LRNLT,4,LRICPT,0),U,3),LRINA=$P(^(0),U,4)
67 . I LRREL&(LRINA="") S LRFLG=0
68 . I LRFLG,EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA="")) S LRFLG=0
69 . Q:'$G(CPT)!(LRFLG)
70 . I '$P($$CPT^ICPTCOD(CPT,$P(LREDT,"."),,),U,7) S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=4 Q
71 . S LRREL=$P(^LAM(LRNLT,4,LRICPT,0),U,3),LRINA=$P(^(0),U,4)
72 . D:LRREL&(LRINA="") SET Q
73 . D:EDATE>(LRREL-1)&((EDATE<LRINA)!(LRINA="")) SET
74 Q
75LOC ;Called from LRCAPPNP
76 I '$G(LRAA) S LRNOP=4 Q
77 S LRDSSLOC=$S($G(^LRO(68,+LRAA,.8)):+^(.8),1:LRDLOC)
78 I 'LRDSSLOC S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=4 S LRNOP=4 Q
79 S LRDSSID=+$P($G(^SC(LRDSSLOC,0)),U,7)
80 I 'LRDSSID S:$D(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)=5 S LRNOP=5
81 Q
82SET ;SET IF VALID PROCEDURE
83 I $G(LRNP),'$D(LRNPX(CPT))#2 Q
84 I '$D(^TMP("LRMOD",$J,CPT)) S ^(CPT)="" D
85 . N X
86 . S X=$$CODM^ICPTCOD(CPT,"^TMP(""LRMOD"",$J,CPT)",,)
87 ;LRCNT=CPT POSITION IN TABLE LRXCPT
88 ;LRCCT=LOCATION POSITION IN TABLE LRXCPT
89 I $G(LRXCPT(CPT)) S LRCNT=LRXCPT(CPT)
90 I '$G(LRXCPT(CPT)) S (LRCNT,LRCCT)=$G(LRCCT)+1,LRXCPT(CPT)=LRCCT
91 ;S LRCNT=LRXCPT(CPT)
92 I '$G(LRNP) S LRXCPT(CPT,"P",LRCNT)=1+$G(LRXCPT(CPT,"P",LRCNT))
93 I $G(LRNP) D
94 . S LRXCPT(CPT,"P",LRCNT)=($G(LRNPX(CPT))-1)
95 . S LRNPX(CPT)=(LRNPX(CPT)-1)
96 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ENC PROVIDER")=LRPRO
97 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"PROCEDURE")=CPT
98 I $G(LRNP) D
99 . Q:$G(LRXCPT(CPT,"P",LRCNT))>0
100 . S LRXCPT(CPT,"P",LRCNT)=1
101 . S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DELETE")=1
102 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"QTY")=$S($G(LRXCPT(CPT,"P",LRCNT)):LRXCPT(CPT,"P",LRCNT),1:1)
103 Q:$G(LRNP)
104 I $G(LRXCPT(CPT,"P",LRCNT))>1,$D(^TMP("LRMOD",$J,CPT,59))>0 D
105 . S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
106 ;If Manual CPT coding always set modifier to 59 to force PCE to add CPT code.
107 I $G(LRES) S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",59)=""
108 I $G(LRAA) D
109 .S MOD=$$GMOD^LRBEBA2(LRAA,CPT)
110 .I MOD'="" S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"MODIFIERS",MOD)="" K MOD
111 S LRXTST(LRTST)=LRNLTN_U_LRTSTP
112 I $G(LRAA),$P($G(^LRO(68,LRAA,0)),U,2)="MI" D
113 . Q:('$D(^TMP("LRPXAPI",$J,"PROCEDURE")))
114 . ;Get PCE data via Billing Aware API for Microbiology
115 . D MICRO1^LRBEBA3(LRCDT,LRSN,LRTST,LRCNT)
116 . I '$D(^TMP("LRPXAPI",$J,"PROCEDURE")) S ^LRO(69,"AA",LRCEX,LROA)=9
117 Q
118SEND ;BUILD ENCOUNTER INFO Called from LRCAPPNP
119 I '$G(LRESCPT) Q:$G(^LRO(69,"AA",$G(LRCEX),$G(LROA)))
120 N LRENCDT ; Check for incorrect time
121 S LRENCDT=$J(LREDT,7,4),LRENCDT(1)=$P(LRENCDT,".",2)
122 S:'LRENCDT(1) LRENCDT(1)=1201
123 I $E(LRENCDT(1),3,4)>59 S LRENCDT(1)=$E(LRENCDT(1),1,2)_59
124 I $E(LRENCDT(1),1,2)>23 S LRENCDT(1)=23_$E(LRENCDT(1),3,4)
125 S $P(LRENCDT,".",2)=LRENCDT(1)
126 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"DSS ID")=LRDSSID
127 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"ENC D/T")=LRENCDT
128 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"HOS LOC")=LRDSSLOC
129 S:LRNINS ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"INSTITUTION")=LRNINS
130 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"PATIENT")=DFN
131 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"SERVICE CATEGORY")="X"
132 S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,"ENCOUNTER TYPE")="A"
133PCE ;SEND DATA TO PCE
134 N LRLNOW,LRAAX
135 K LRVSITN S (LROK,LRVSITN)=""
136 I $G(LRAA) S LRAAX=$P($G(^LRO(68,LRAA,0)),U,2)
137 I ($G(LRAAX)="CH") S LROK=1,LRVSITN=$G(LRBEVSIT)
138 I ($G(LRAAX)="MI") D
139 . Q:('$D(^TMP("LRPXAPI",$J,"PROCEDURE")))
140 . ;Get PCE data via Billing Aware API for Microbiology
141 . D MICRO2^LRBEBA3(LRCDT,LRSN)
142 . S LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$G(LRDUZ))
143 . K ^TMP("LRBEDX",$J)
144 I (";AU;BB;CY;EM;SP;"[(";"_$G(LRSS)_";"))!(";AU;BB;CY;EM;SP;"[(";"_$G(LRAAX)_";")) D
145 .S LROK=$$DATA2PCE^PXAPI("^TMP(""LRPXAPI"",$J)",LRPKG,"LAB DATA",.LRVSITN,$G(LRDUZ))
146 I $G(^XTMP("LRPCELOG",0)) D ;Used to log/debug contents of ^TMP("LRPXAPI")
147 . F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",1,LRLNOW)) H 1
148 . S ^XTMP("LRPCELOG",1,LRLNOW,0)=U_$G(LRBEID)_U_$G(LRVSITN)
149 . M ^XTMP("LRPCELOG",1,LRLNOW)=^TMP("LRPXAPI",$J)
150 W:$G(LRDBUG) !,"LROK = ",LROK,!,$G(LRVSITN)
151 Q:$G(LRESCPT)
152 I '$G(LRNP),$D(^LRO(69,LRCDT,1,LRSN,"PCE")) S:LRVSITN ^("PCE")=$E(^("PCE")_$S(LROK>0:LRVSITN,1:LROK)_";",1,30) D
153 . I LROK<1,$D(^LRO(69,"AA",LRCEX,LROA)) S ^(LROA)=LROK
154EN7 N LRFND,LRPCE
155 Q:'$G(LRNP)!(LROK<1)!('LRVSITN)
156 S LRPCE=$G(^LRO(69,LRCDT,1,LRSN,"PCE"))
157 I '$F(LRPCE,LRVSITN_"-CPT CANC") D
158 . S LRFND=$F(LRPCE,LRVSITN) Q:'LRFND
159 . I LRFND S LRPCE=$E(LRPCE,1,(LRFND-1))_"-CPT CANC"_$E(LRPCE,LRFND,$L(LRPCE))
160 . S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
161CHK ;Determine if any CPT code remain on the encounter, then delete encounter if false
162 K ^TMP("PXKENC",$J)
163 D ENCEVENT^PXKENC(LRVSITN,1)
164 I $O(^TMP("PXKENC",$J,LRVSITN,"CPT",0)) K ^TMP("PXKENC",$J) Q
165 S LROK=$$DELVFILE^PXAPI("ALL",$G(LRVSITN),LRPKG,"LAB DATA",0,0,0)
166 K ^TMP("PXKENC",$J) Q:LROK<1
167 N LRSN
168 S LRSN=0
169 F S LRSN=$O(^LRO(69,"C",LRCE,LRCDT,LRSN)) Q:LRSN<1 D DELCAN
170 Q
171DELCAN ;Mark PCE Encounter number as '-CPT CANC-ENC DEL'
172 ;LRVSITN = Encounter IEN
173 S LRPCE=$G(^LRO(69,LRCDT,1,LRSN,"PCE")) Q:'$L(LRPCE) D
174 . Q:'$G(LRVSITN)
175 . I $F(LRPCE,LRVSITN_"-CPT CANC-ENC DEL;") Q
176 . S LRFND=$F($G(LRPCE),LRVSITN_"-CPT CANC") I LRFND D Q
177 . . S LRPCE=$E(LRPCE,1,(LRFND-1))_"-ENC DEL"_$E(LRPCE,LRFND,$L(LRPCE))
178 . . S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
179 . S LRFND=$F($G(LRPCE),LRVSITN) I LRFND D
180 . . S LRPCE=$E(LRPCE,1,(LRFND-1))_"-CPT CANC-ENC DEL"_$E(LRPCE,LRFND,$L(LRPCE))
181 . . S ^LRO(69,LRCDT,1,LRSN,"PCE")=$E(LRPCE,1,30)
182 Q
183TEST ;
184 S:'$G(LRDPRAC) LRDPRAC=DUZ
185 S LRDLOC=+$G(^LAB(69.9,1,.8))
186 S:'$G(LRPKG) LRPKG=26 S:'$G(LRDBUG) LRDBUG=1 S LRVSIT=2
187 S:'$G(LRCDT) LRCDT=DT S:'$G(LRSN) LRSN=1 S NODE=^LRO(69,LRCDT,1,LRSN,0)
188 S NODE(1)=^LRO(69,LRCDT,1,LRSN,1)
189 S DFN=$P(^LR(+NODE,0),U,3)
190 D EN3
191 Q
Note: See TracBrowser for help on using the repository browser.