source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPPH3.m@ 1800

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

initial load of WorldVistAEHR

File size: 6.4 KB
Line 
1LRCAPPH3 ;DALOI/FHS/PC - CHECK CPT CODE AND FILE POINTERS ; 5/1/99
2 ;;5.2;LAB SERVICE;**263,291**;Sep 27, 1994
3 ;Called from LRCAPPH,LRCAPPH4
4EN ;
5 K ^TMP("LRCAPPH",$J),LRSEP S LRSEP(1)="==================="
6 S LRSEP(2)="****************"
7 K %DT S %DT="",X="T+5" D ^%DT S LRPGDT=Y
8 S ^TMP("LRCAPPH",$J,0)=Y_U_$$NOW^XLFDT_U_"LAB CPT DATA CHECKER"
9 S ^TMP("LRCAPPH60",$J,0)=Y_U_$$NOW^XLFDT_U_"LAB 60 CPT DATA CHECKER"
10 K %DT S %DT="" S X="T-1" D ^%DT S LRINADT=$$FMTE^XLFDT(Y,1)
11 S LRINADTX=Y K %DT
12AA ;Look for CPT processing errors
13 D
14 . N LRAAN,LRCE,LRTXT,LRX
15 . S LRAAN="^LRO(69,""AA"")"
16 . F S LRAAN=$Q(@LRAAN) Q:$QS(LRAAN,2)'="AA" D
17 . . S LRX=@LRAAN Q:'LRX S LRCE=$QS(LRAAN,3)
18 . . K LRTXT
19 . . S LRTXT="Lab Order Number "_LRCE_" "
20 . . I LRX<1 D
21 . . . S LRTXT(1)=LRTXT_" was rejected by the PCE API "
22 . . I LRX=2 D
23 . . . S LRTXT(1)=LRTXT_"has no Institution for the ordering location."
24 . . I LRX=3 D
25 . . . S LRTXT(1)=LRTXT_"Provider is InActive."
26 . . I LRX=4 D
27 . . . S LRTXT(1)=LRTXT_"Not Processed "
28 . . . S LRTXT(2)=" - No DEFAULT LAB OOS LOCATION defined."
29 . . I LRX=5 D
30 . . . S LRTXT(1)=LRTXT_"Ordering Location "
31 . . . S LRTXT(2)=" has no STOP CODE NUMBER defined."
32 . . I $D(LRTXT(1)) S LRTXT(10)=LRSEP(1) D MSGSET("LRCAPPH",.LRTXT)
33LAM ;Look for inactive Codes and broken pointers.
34 ;in ^LAM
35 N LRI,LRXDT,LRY,LRII
36 S LRI=0 F S LRI=$O(^LAM(LRI)) Q:LRI<1 D I '$D(ZTQUEUED) W:'(LRI#50) "."
37 . I '$G(LRACT) Q:'$O(^LAM(LRI,7,0))
38 . S LRII=0 F S LRII=$O(^LAM(LRI,4,LRII)) Q:LRII<1 D
39 . . I '$G(^LAM(LRI,4,LRII,0)) W:'$D(ZTQUEUED) !,"@@@@@@@@@@@",LRI,! D Q
40 . . . I '$L($P($G(^LAM(LRI,4,LRII,0)),U)) K ^LAM(LRI,4,LRII) Q
41 . . . N DR,DA,DIE,DIK
42 . . . S DA=LRII,DA(1)=LRI,DIK="^LAM("_LRI_",4," D ^DIK
43 . . K LRX S LRX=^LAM(LRI,4,LRII,0) D CK
44LAB ;Look for inactive Codes in ^LAB
45 N LRJ,LRN,LRSPEC,LRBECPT,MSGTYPE,MSGFLAG,DEFAULT,HCPCS,Y
46 S LRJ=0 F S LRJ=$O(^LAB(60,LRJ)) Q:'LRJ D
47 . S MSGFLAG=0
48 . S X=^LAB(60,LRJ,0),LRN=$P(X,U,1)
49 . I ($P(X,U,4)'="CH")&($P(X,U,4)'="MI") Q
50 . S LRSPEC=0 F S LRSPEC=$O(^LAB(60,LRJ,1,LRSPEC)) Q:'LRSPEC D
51 . . K LRBECPT
52 . . D IACPT(LRJ,DT,LRSPEC)
53 . . Q:('$D(LRBECPT(LRJ)))
54 . . S X=$O(LRBECPT(LRJ,1,0)) Q:'X
55 . . S MSGTYPE="SPECIMEN ("_LRSPEC_") CPT"
56 . . D MSG2(MSGTYPE)
57 . S X=$G(^LAB(60,LRJ,1.1)) S DEFAULT=$P(X,U,1),HCPCS=$P(X,U,2)
58 . I HCPCS D
59 . . S MSGTYPE="HCPCS CPT"
60 . . S X=HCPCS,Y=$$CPT^ICPTCOD(X,,,) I '$P(Y,U,7) S X=$P(Y,U,2) D MSG2(MSGTYPE)
61 . I DEFAULT D
62 . . S MSGTYPE="DEFAULT CPT"
63 . . S X=DEFAULT,Y=$$CPT^ICPTCOD(X,,,) I '$P(Y,U,7) S X=$P(Y,U,2) D MSG2(MSGTYPE)
64 . I MSGFLAG D MSGSET("LRCAPPH60",.LRMSG)
65 Q
66 ;
67IACPT(LRBETST,LRBECDT,LRSPEC) ; Get inactive specimen CPT
68 N A,ARR,LRBEAX,LRBEIEN,LRBEAR60,X
69 S LRBEIEN=LRSPEC_","_LRBETST_",",(LRI,LRBECPT)=""
70 D GETS^DIQ(60.01,LRBEIEN,"96*","I","LRBEAR60")
71 S A="" F S A=$O(LRBEAR60(60.196,A)) Q:A="" D
72 . Q:$G(LRBEAR60(60.196,A,1,"I"))=""
73 . S ARR($G(LRBEAR60(60.196,A,1,"I")))=$G(LRBEAR60(60.196,A,.01,"I"))
74 S X=$O(ARR(LRBECDT),-1) I X D
75 .S LRBEAX=ARR(X)
76 .S LRBEAX=$$CPT^ICPTCOD(LRBEAX,LRBECDT)
77 .I '$P(LRBEAX,U,7) S LRBECPT(LRBETST,1,$P(LRBEAX,U,2))="SPECIMEN CPT"
78 Q
79 ;
80EN0 ;Entry point for scan 64, scan 60, and mail reports to G.LMI
81 ;Called from LRCAPPH
82 D EN
83 D MAIL
84 D MAIL2
85END ;Called from LRCAPPH4
86 I $E($G(IOST),1,2)="P-" W @IOF
87 K DA,DIC,DIE,DIK,DR,I
88 K LRACT,LRCMT,LRINADT,LRINADTX,LRI,LRII,LRMSG,LRN,LRPGDT,LRTST,LRSEP,LRX
89 K LRTXT,X,XMTEXT,XMSUB,Y
90 K ^TMP("LRCAPPH",$J),^TMP("LRCAPPH60",$J)
91 D ^%ZISC
92 Q
93ACTIVE ;Print only WKLD CODES that have associated test assigned
94 ;and do not have inactivation dates
95 S LRACT=1 D EN0
96 Q
97CK ;
98 I '$G(LRACT) Q:$P(LRX,U,4)
99 K X,Y,DIC,LRMSG
100 F I=1:1:5 S LRX(I)=$P(LRX,U,I)
101 I LRX(2)="CPT" D Q
102 . S X=$P(LRX(1),";")
103 . S Y=$$CPT^ICPTCOD(X,,,) I $S('$P(Y,U,7):1,LRX(4):1,1:0) D
104 . . S ^TMP("LRCAPPH",$J,"ICPT",X)=""
105 . . S Y(0)=$P(Y,U,2,3)_"^^1"
106 . . D MSG
107 S DIC(0)="XOZ",X=+LRX(1),DIC=U_$P(LRX(1),";",2)
108 S:$E(LRX(2))="L" DIC("S")="I '$P($G(^(4)),U)"
109 D ^DIC
110 I Y<1 D MSG Q
111 I $G(LRX(4)) D MSG
112 Q
113MSG ;
114 K LRMSG
115 S LRN=^LAM(LRI,0)
116 S LRCMT=$P($G(^TMP("LRCAPPH",$J,0)),U,4)+1
117 S LRMSG(LRCMT)=$P(LRN,U,2)_" ["_LRI_"] "_$P(LRN,U),LRCMT=LRCMT+1
118 I Y<1 D Q
119 . S LRMSG(LRCMT)="*** Has an invalid "_LRX(2)_" code of "_+X_" ."
120 . D TST
121 . I '$P(^LAM(LRI,4,LRII,0),U,4) S $P(^(0),U,4)=LRINADTX D
122 . . S LRCMT=LRCMT+1,LRMSG(LRCMT)="Inactivation date of "_LRINADT_" has been entered."
123 . S LRCMT=LRCMT+1,LRMSG(LRCMT)=LRSEP(1)
124 . D MSGSET("LRCAPPH",.LRMSG)
125 I $P($G(Y(0)),U,4) D
126 . N LRXDT
127 . S LRCMT=LRCMT+1,LRMSG(LRCMT)=$P(Y(0),U)_" "_$P(Y(0),U,2),LRCMT=LRCMT+1
128 . S LRMSG(LRCMT)="Is an inactive "_LRX(2)_" code."
129 . D TST
130 . S:'$P(^LAM(LRI,4,LRII,0),U,4) $P(^(0),U,4)=LRINADTX
131 . S LRXDT=$P(^LAM(LRI,4,LRII,0),U,4)
132 . S LRCMT=LRCMT+1,LRMSG(LRCMT)="Inactivation date of "_$$FMTE^XLFDT(LRXDT,1)_" has been entered."
133 . S LRCMT=LRCMT+1,LRMSG(LRCMT)=LRSEP(2)
134 . D MSGSET("LRCAPPH",.LRMSG)
135 Q
136MAIL ;Send message to G.LMI local mail group
137 Q:'$O(^TMP("LRCAPPH",$J,0))
138 N DUZ,XMDUZ,XMSUB,XMTEXT
139 S LRCMT=$G(LRCMT)+1
140 S ^TMP("LRCAPPH",$J,LRCMT,0)="Listing of all offending codes:"
141 S LRCMT=$G(LRCMT)+1,^TMP("LRCAPPH",$J,LRCMT,0)=""
142 S LRC="^TMP(""LRCAPPH"",$J,""A"")" F S LRC=$Q(@LRC) Q:$QS(LRC,2)'=$J D
143 . S LRCMT=LRCMT+1,^TMP("LRCAPPH",$J,LRCMT,0)=" "_$QS(LRC,3)_" "_$QS(LRC,4)
144 S XMSUB=" NIGHTLY WKLD CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
145 S XMY("G.LMI")="",XMTEXT="^TMP(""LRCAPPH"","_$J_","
146 D ^XMD
147 Q
148TST ;
149 Q:'$O(^LAM(LRI,7,0))
150 K LRT N X
151 S LRCMT=$G(LRCMT)+1 S LRMSG(LRCMT)="Associated Tests"
152 S LRT=0 F S LRT=$O(^LAM(LRI,7,LRT)) Q:LRT<1 S LRTST=$G(^(LRT,0)) D
153 . S X=+LRTST
154 . S LRTST="^"_$P(LRTST,";",2)_$P(LRTST,";")_",0)",LRCMT=LRCMT+1
155 . S LRMSG(LRCMT)=" "_$P(@LRTST,U)_" {"_X_"}"
156 Q
157MSGSET(SUB,TXT) ;SUB=subscript - TXT = array containing the message
158 N I ;
159 S LRCMT=$P($G(^TMP(SUB,$J,0)),U,4)
160 S I=0 F S I=$O(TXT(I)) Q:I<1 D
161 . S LRCMT=LRCMT+1,^TMP(SUB,$J,LRCMT,0)=TXT(I)
162 S $P(^TMP(SUB,$J,0),U,4)=LRCMT
163 Q
164 ;
165MSG2(MSGTYPE) ;
166 I 'MSGFLAG D
167 . K LRMSG
168 . S LRCMT=$P($G(^TMP("LRCAPPH",$J,0)),U,4)+1,LRMSG(LRCMT)=" "
169 . S LRCMT=LRCMT+1,LRMSG(LRCMT)=$P(LRN,U,1)_" ["_LRJ_"]"
170 S LRCMT=LRCMT+1
171 S LRMSG(LRCMT)="*** Has an inactive "_MSGTYPE_" Code of "_X_".",MSGFLAG=1
172 Q
173 ;
174MAIL2 ;Send message to G.LMI local mail group
175 N DUZ,XMDUZ,XMSUB,XMTEXT
176 Q:'$O(^TMP("LRCAPPH60",$J,0))
177 S LRCMT=$G(LRCMT)+1,^TMP("LRCAPPH60",$J,LRCMT,0)=" "
178 S XMSUB="NIGHTLY FILE #60 CPT CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
179 S XMY("G.LMI")="",XMTEXT="^TMP(""LRCAPPH60"","_$J_","
180 D ^XMD
181 Q
Note: See TracBrowser for help on using the repository browser.