source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRBEBA5.m@ 811

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1LRBEBA5 ;DALOI/JAH/FHS - PENDING PANEL ROLLUP TO PCE ;11/26/2005
2 ;;5.2;LAB SERVICE;**291,337**;Sep 27, 1994;Build 2
3 ;
4EN ;Entry point from LRNIGHT
5 ;check rollup date
6 N LRBEROLL,LRBERLDT,DATX,YY,MM,STARTDT,ENDDT,NEWDT,TOTPAN
7 S LRBEROLL=0,LRBERLDT=$P(^LAB(69.9,1,"VSIT"),U,2)
8 S YY=$E(LRBERLDT,1,3),MM=+$E(LRBERLDT,4,5)
9 S MM=$S(MM=1:12,1:MM-1) S YY=$S(MM=12:YY-1,1:YY) I $L(MM)=1 S MM="0"_MM
10 S STARTDT=YY_MM_"01",ENDDT=YY_MM_"31"_".999999"
11 S DATX=$O(^LRO(69,"APP",0))
12 I DATX<STARTDT S STARTDT=DATX-1
13 I LRBERLDT=DT S LRBEROLL=1
14 I (LRBERLDT<DT) I DATX<ENDDT S LRBEROLL=1
15 I LRBEROLL D
16 .K ^TMP("LRROLLUP",$J)
17 .S ^TMP("LRROLLUP",$J,0)=$$NOW^XLFDT_"^"
18 .D START
19 .D NEWDT
20 .S ^TMP("LRROLLUP",$J,0)=^TMP("LRROLLUP",$J,0)_$$NOW^XLFDT()
21 .D MAILRPT
22 Q
23 ;
24START ;Loop thru pending panel xref in file #69
25 N LINE,LRXDT,LRODT,LRSN,LRTN
26 S LINE=100,TOTPAN=0
27 S LRXDT=STARTDT F S LRXDT=$O(^LRO(69,"APP",LRXDT)) Q:'LRXDT Q:LRXDT>ENDDT D
28 .S LRODT=0 F S LRODT=$O(^LRO(69,"APP",LRXDT,LRODT)) Q:'LRODT D
29 ..S LRSN=0 F S LRSN=$O(^LRO(69,"APP",LRXDT,LRODT,LRSN)) Q:'LRSN D
30 ...S LRTN=0 F S LRTN=$O(^LRO(69,"APP",LRXDT,LRODT,LRSN,LRTN)) Q:'LRTN D
31 ....D SET
32 ....I $D(LRBEY)>1 D BAWRK^LRBEBA(LRODT,LRSN,LRTN,.LRBEY,.LRTEST,"","",LRBEROLL)
33 ....I $D(LRBECPT)>1 D SETRPT
34 ....D CLEAN
35 Q
36 ;
37SET ;Setup background variables for call to BAWRK^LRBEBA
38 N LRBET,LRBEIEN,LRFDA,I,NX,XX
39 S LRBEIEN=LRSN_","_LRODT_","
40 S LRDFN=$$GET1^DIQ(69.01,LRBEIEN,.01,"I")
41 S LRORDER=$$GET1^DIQ(69.01,LRBEIEN,9.5,"I")
42 S LRBEIEN=LRTN_","_LRSN_","_LRODT_","
43 I $$GET1^DIQ(69.03,LRBEIEN,8,"I")="CA" D Q
44 .;clear 'pending panel' xref of not performed panel
45 .S LRFDA(1,69.03,LRBEIEN,22.1)=0
46 .D FILE^DIE("KS","LRFDA(1)","ERR")
47 S LRBETST=$$GET1^DIQ(69.03,LRBEIEN,.01,"I")
48 I LRBETST="" K ^LRO(69,"APP",LRXDT,LRODT,LRSN,LRTN) Q
49 S LRAD=+$$GET1^DIQ(69.03,LRBEIEN,2,"I")
50 S LRAA=+$$GET1^DIQ(69.03,LRBEIEN,3,"I")
51 S LRAN=+$$GET1^DIQ(69.03,LRBEIEN,4,"I")
52 S LRUID=$$GET1^DIQ(69.03,LRBEIEN,13,"I")
53 S LRBECDT=$$GET1^DIQ(69.03,LRBEIEN,22,"I")
54 S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
55 S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
56 I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBETST,0))="" K ^LRO(69,"APP",LRXDT,LRODT,LRSN,LRTN) Q
57 S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
58 S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
59 I I S X=^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0),LRSPEC=$P(X,U,1),LRSAMP=$P(X,U,2)
60 S NX=0 F S NX=$O(^LAB(60,LRBETST,2,NX)) Q:'NX D
61 .S LRBET=+^LAB(60,LRBETST,2,NX,0)
62 .S XX=$P($P(^LAB(60,LRBET,0),U,5),";",2)
63 .;if null XX, possibly another panel
64 .I 'XX D ARRS(LRBET,LRBETST) Q
65 .S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
66 .I LRSB(XX)="" K LRSB(XX) Q
67 .I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
68 .I $P(LRSB(XX),U,13) K LRSB(XX) Q
69 .S LRBEY(LRBETST,XX)=""
70 I $D(LRBEY)>1 D
71 .S LRTEST(1)=LRBETST_U_^LAB(60,LRBETST,0),LRTEST(1,"P")=LRBETST_U_$$NLT^LRVER1(LRBETST)
72 Q
73 ;
74ARRS(XTEST,PTEST) ;
75 N NX,X,XX
76 S NX=0 F S NX=$O(^LAB(60,XTEST,2,NX)) Q:'NX D
77 .S X=+^LAB(60,XTEST,2,NX,0)
78 .S XX=$P($P(^LAB(60,X,0),U,5),";",2)
79 .Q:'XX
80 .S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
81 .I LRSB(XX)="" K LRSB(XX) Q
82 .I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
83 .I $P(LRSB(XX),U,13) K LRSB(XX) Q
84 .S LRBEY(PTEST,XX)=""
85 Q
86 ;
87CLEAN ;Clean-up variables
88 K DFN,LRBEY,LRTEST,LRSB,LRBECPT,LRDFN,LRBEDFN,LRORDER
89 K LRBETST,LRBEVST,LRAA,LRAN,LRAD,LRUID,LRBECDT,LRSS,LRIDT,LRSAMP,LRSPEC
90 Q
91 ;
92SETRPT ;Set veriables into ^TMP( for report
93 N SETLN,X,C,N,T,TNM,XCODE,LRPCE,LRBETST,LRBETSTN
94 S TOTPAN=TOTPAN+1
95 S SETLN="S LINE=LINE+1,^TMP(""LRROLLUP"",$J,LINE,0)=X"
96 S LRPCE=$P(^LRO(69,LRODT,1,LRSN,"PCE"),U,1)
97 Q:LRPCE=""
98 S LRBETST=$P(LRTEST(1),U,1)
99 S LRBETSTN=$P(^LAB(60,LRBETST,0),U,1),LRBETSTN="["_LRBETST_"] "_$E(LRBETSTN,1,30)
100 S X=$$SETSTR^VALM1(LRORDER,"",1,10),X=$$SETSTR^VALM1(LRUID,X,12,10)
101 S X=$$SETSTR^VALM1(LRPCE,X,26,10),X=$$SETSTR^VALM1(LRBETSTN,X,40,38) X SETLN
102 S T=0,N=0 F S T=$O(LRBECPT(T)) Q:'T D
103 . S N=N+1,TNM="["_T_"] "
104 . I N=1 S X=$$SETSTR^VALM1("CPT Code(s) passed to PCE:","",12,28)
105 . I N>1 S X=""
106 . S C=$O(LRBECPT(T,1,0)),XCODE=$P($$CPT^ICPTCOD(C),U,2,3),XCODE=$TR(XCODE,"^"," "),XCODE=$E(XCODE,1,30)
107 . S XCODE=TNM_XCODE,X=$$SETSTR^VALM1(XCODE,X,40,38) X SETLN
108 S X=" " X SETLN
109 Q
110 ;
111NEWDT ;Set new roll-up date
112 N DD,MM,MM2,X1,X,YY
113 Q:'$G(LRBERLDT)
114 S MM=+$E(LRBERLDT,4,5) S MM2=$S(MM=12:1,1:MM+1) S:$L(MM2)=1 MM2="0"_MM2
115 S DD=$E(LRBERLDT,6,7) S YY=$E(LRBERLDT,1,3) S:+MM2=1 YY=YY+1
116 S NEWDT=YY_MM2_DD
117 S X1=NEWDT,X=+$E(NEWDT,4,5),X=$S("^1^3^5^7^8^10^12^"[(U_X_U):31,X'=2:30,$E(X1,1,3)#4:28,1:29)
118 I $E(X1,6,7)'<X S $E(NEWDT,6,7)=X-1
119 S $P(^LAB(69.9,1,"VSIT"),U,2)=NEWDT
120 Q
121 ;
122MAILRPT ;Set intro & send rollup report to mail group
123 N XMY,XMSUB,XMDUZ,XMTEXT,XMZ,X,X1,Y,SETLN,LINE,DASH
124 S ENDDT=$P(ENDDT,".",1),X=ENDDT D
125 .S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[(U_X_U):31,X'=2:30,$E(X1,1,3)#4:28,1:29)
126 .I $E(X1,6,7)>X S $E(ENDDT,6,7)=X
127 S LINE=0,SETLN="S LINE=LINE+1,^TMP(""LRROLLUP"",$J,LINE,0)=X"
128 S $P(DASH,"-",78)=""
129 S X=" " X SETLN
130 S X="Normally, panel tests flagged as 'AMA/Billable' should be reported to PCE" X SETLN
131 S X="using the CPT Code of the panel. In order for the panel CPT Code to be" X SETLN
132 S X="sent to PCE, a verified result must be present for each 'required' atomic" X SETLN
133 S X="test comprising the panel." X SETLN
134 S X=" " X SETLN
135 S X="This report provides a listing of AMA/Billable panel tests that were pending" X SETLN
136 S X="completion on the Lab Roll-up Date. The Sample Collection Date for the" X SETLN
137 S X="panel test fell within the date range indicated by Start Date and End Date." X SETLN
138 S X="One or more of the 'required' atomic tests comprising the panel were still" X SETLN
139 S X="pending on the Lab Roll-up Date. Therefore, those atomic tests that had" X SETLN
140 S X="been verified have now been sent to PCE. If other atomic tests from the" X SETLN
141 S X="panels listed are verified later, each will be sent to PCE using the CPT" X SETLN
142 S X="Code for the atomic test." X SETLN
143 S X=" " X SETLN
144 S X=" " X SETLN
145 S Y=LRBERLDT D DD^%DT S LRBERLDT=Y
146 S X="Lab Roll-up Date : "_LRBERLDT X SETLN
147 S Y=NEWDT D DD^%DT S NEWDT=Y
148 S X="Next Lab Roll-up Date : "_NEWDT X SETLN
149 S Y=STARTDT D DD^%DT S STARTDT=Y
150 S X="Start Date : "_STARTDT X SETLN
151 S Y=ENDDT D DD^%DT S ENDDT=Y
152 S X="End Date : "_ENDDT X SETLN
153 S X="Total # Panels : "_TOTPAN X SETLN
154 S X=" " X SETLN
155 S X=" " X SETLN
156 S X=$$SETSTR^VALM1("Unique","",12,10),X=$$SETSTR^VALM1("PCE",X,26,10) X SETLN
157 S X=$$SETSTR^VALM1("Order #","",1,10),X=$$SETSTR^VALM1("Identifier",X,12,10),X=$$SETSTR^VALM1("Encounter",X,26,10)
158 S X=$$SETSTR^VALM1("Panel Test",X,40,38) X SETLN
159 S X=$$SETSTR^VALM1(DASH,"",1,78) X SETLN
160 S Y=DT D DD^%DT S XMSUB="Report on Roll-up to PCE for "_Y
161 S XMDUZ=.5
162 S XMY("G.LMI")=""
163 S XMTEXT="^TMP(""LRROLLUP"",$J,"
164 D ^XMD
165 K ^TMP("LRROLLUP",$J)
166 Q
Note: See TracBrowser for help on using the repository browser.