source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRCAPPH.m

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1LRCAPPH ;DALOI/FHS - PROCESS PHLEBOTOMY WORKLOAD DATA ; 5/1/99
2 ;;5.2;LAB SERVICE;**1,19,127,136,138,158,153,263,264**;Sep 27, 1994
3 ;**DBIA 1995-A Retrieve CPT codes
4 ;**DBIA 1995-B Retrieve CPT Modifiers
5 ;**DBIA 1889-A Pass PCE Encounter Data
6 ;**DBIA 1889-B Delete PCE Entries
7 ;**DBIA 1889-F Extract PCE Data
8 ; Reference to ^DIC(9.4, Supported by Reference 10048
9 ; Reference to ^SC( Supported by Reference 10040
10 ; Reference to ^%ZOSF("TEST") Supported by Reference #10096
11 ; Reference to ^DIC(40.7 Supported by Reference #923
12 ; Reference to ^XMB(1 Supported by Reference #10091
13 ; Reference to T0^%ZOSV Supported by Reference #10097
14 ; Reference to T1^%ZOSV Supported by Reference #10097
15 ; Reference to ^DIC( Supported by Reference #10006
16 ; Reference to EN3^SDACS Supported by DBIA #10041
17 ; No longer called
18 ; Reference to $$PKGON^VSIT Supported by DBIA #1900-E
19 ; Reference to $$NOW^XLFDT Supported by Reference #10103
20 ; Reference to $$GET^XUA4A72 Supported by Reference #1625
21EN ;
22 I $G(^LRO(69,"AE"))'=DT D
23 . D EN0^LRCAPPH3
24 . S ^LRO(69,"AE")=DT
25NP ;Not performed entry tag Called from LRCAPPNP
26 N LRSPEC,LR657,LR658
27 D
28 . K DIC S DIC="^LAM(",DIC(0)="ONMX"
29 . S X="89343.0000",LR657=657 D ^DIC I Y>1 S LR657=+Y
30 . S X="89341.0000",LR658=658 D ^DIC I Y>1 S LR658=+Y
31 K ^LRO(69,"AE",0)
32 I $G(LRNP) S LRNOPX=1
33 I $D(ZTQUEUED) S ZTREQ="@" K LRDBUG
34 I '$G(LRDBUG) K ^TMP("LRMOD",$J)
35 S LRDPRAC=+$P($G(^LAB(69.9,1,12)),U)
36 I LRDPRAC D
37 . N DIC,X
38 . S DIC(0)="NZ",DIC=200,X="`"_LRDPRAC
39 . D ^DIC S LRDPRAC=$S(Y<1:0,$P($G(Y(0)),U,11):0,1:+Y)
40 . I $$GET^XUA4A72(LRDPRAC)<1 S LRDPRAC=0
41 S LROK=+$G(^LAB(69.9,1,.8)) G:'LROK END0
42 I $P($G(^SC(LROK,0)),U)'["LAB DIV " G END0
43 K LROK
44 I '$G(LRNP) L +^LRO("LRCAPPH","NITE"):1 G:'$T END0
45 S:'$D(^LAB(69.9,1,"NITE")) ^("NITE")=""
46 S LRWRKL=$S($P(^LAB(69.9,1,0),U,14):1,1:0)
47 I $D(XRTL) S XRTN="LRCAPPH" D T0^%ZOSV
48 S LRPKG=$O(^DIC(9.4,"C","LR",0))
49 S:'LRPKG LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
50 G:'LRPKG END0
51 S LRVSIT=$P($G(^LAB(69.9,1,"VSIT")),U)
52 S X="PXAI" X ^%ZOSF("TEST") I '$T G END0
53 S:'$G(LRNP) $P(^LAB(69.9,1,"NITE"),U,2)=$$NOW^XLFDT
54 S LRPCEON=$$PKGON^VSIT("PX")
55 S ^TMP("LRMOD",$J)=""
56SDC S SDC=$S($P(^LAB(69.9,1,"NITE"),U,3):$G(^DIC(40.7,+$P(^LAB(69.9,1,"NITE"),U,3),0)),1:"") S LRSDC=$S($P(SDC,U,2):+$P(SDC,U,2),1:108)
57DSSLOC S LRDLOC=+$G(^LAB(69.9,1,.8))
58 S LCWT=$P($G(^LAM(LR658,0)),U,3)_U_$P($G(^LAM(LR658,0)),U,10)
59 S LSPWT=$P($G(^LAM(LR657,0)),U,3)_U_$P($G(^LAM(LR657,0)),U,10)
60 S LRCSC=+$G(^LAB(69.9,1,"VSIT"))
61 S LRINS=+$P($G(^XMB(1,1,"XUS")),U,17) G END0:'LRINS
62HEAC ;
63 D
64 . N DIC,Y,X
65 . S DIC="^LRO(68,",DIC(0)="MO",X="HEM" D ^DIC
66 . I Y>0 S LRDAA=+Y Q
67 . S LRDAA=10
68 S LRSPEC=$P($G(^LAB(69.9,1,1)),U)
69 I $G(LRNP) S LRNOPX=0 Q
70 S (LRCEX,LRCEXV,LREND,LROA)=0 F S LRCEX=$O(^LRO(69,"AA",LRCEX)) Q:LRCEX=""!(LREND) D
71 . K LRXCPT
72 . S (LROA,LRCC)="" F S LROA=$O(^LRO(69,"AA",LRCEX,LROA)) Q:LROA="" S LRCDT=+LROA,LRSN=+$P(LROA,"|",2) D:LRCDT&(LRSN) LOOK D
73 . . I '$G(LRDBUG) K:'$G(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)
74AE ;Process NP specimens and delete CPT procedures
75 K LRXCPT D ^LRCAPPNP
76END0 Q:$G(LRDBUG)
77 K I,LRAA,LRCC,LRCDT,LRLD,LRIN,LRINS,LRNT,LROA,LRSN,LRPWT,NODE,X,LREND,LRWRKL,SDC,SDIV,SDATE,SDCTYPE,SDMSG,LRSPWT,LOC,LCWT,LSPWT,LRO,LRSDTC,LSPWT,LRSDC
78 K LRVSIT,EDATE,^TMP("LRPXAPI",$J),LRPCEON,DFN,LRCE,LRCSQ,SDUZ,EDATE
79 K LRCEX,LRCEXV,CPT,LRNINS,LRCDT,LREDT,LRCNT,LRI,LRICPT,LRINA,LRNLT,LRPKG
80 K LRREL,LRSN,LRSTP,LRTST,LRTSTP,LRVSIT,NODE,LRPRO
81 K LRDLOC,LRDSSLOC,LRNOP,SDERR,PXKDONE,VSIT,DIC,LRCSC,LRDFN
82 K LRDPRAC,LROK,LRXCPT
83 K ^TMP("LRMOD",$J)
84 I $D(XRT0) S XRTN="END^LRCAPPH" D T1^%ZOSV
85 S $P(^LAB(69.9,1,"NITE"),U,2)="" L -^LRO("LRCAPPH","NITE")
86 Q
87LOOK ;From LRCAPPNP
88 N LRDUZ
89 Q:'$D(^LRO(69,LRCDT,1,LRSN,0))#2 S NODE=^(0)
90 S LRDFN=+NODE Q:'$D(^LR(LRDFN,0))#2 S LRDPF=+$P(^(0),U,2),DFN=+$P(^(0),U,3)
91 Q:'DFN!(LRDPF'=2)
92 S LRDUZ=$S($P(NODE,U,2):$P(NODE,U,2),1:DUZ)
93 S LRCC=$S(($P(NODE,U,4)="LC"!($P(NODE,U,4)="I")):LR658,$P(NODE,U,4)="SP":LR657,1:0)
94 Q:'$D(^LRO(69,LRCDT,1,LRSN,1))#2 S NODE(1)=^(1) Q:$P(NODE(1),U,4)'="C" S LRNT=+NODE(1),LRIN=$S($P(NODE(1),U,8):$P(NODE(1),U,8),1:LRINS),LRCE=+$G(^(.1))
95 I $G(LRNP) S LRNOPX=1 Q
96 D:LRCSC EN3 I 'LRWRKL S:'$G(LRDBUG) $P(^LRO(69,LRCDT,1,LRSN,0),U,10)=1,LRCEXV=$G(LRCEX) Q
97 Q:$G(^LRO(69,"AA",LRCEX,LROA))
98PHLE I $G(LRCC),LRCEX'=$G(LRCEXV) D
99 . S LREDT=$P($G(^LRO(69,LRCDT,1,LRSN,3)),U) Q:'LREDT
100 . N LRCDT,LRIN,DIC,X,Y
101 . S X="`"_$P(NODE,U,9),DIC="^SC(",DIC(0)="NZ" D ^DIC
102 . Q:Y<1
103 . S:Y>0 LROL=+Y,LRIN=$P(Y(0),U,4),LRRRL2=$P(Y(0),U,20),LRRRL4=$P(Y(0),U,3)
104 . S:'LRIN LRIN=LRINS
105 . S LRCDT=$P(LREDT,".")
106 . D:'$D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,0))#2 BLDIN^LRCAPV3
107 . D
108 . . S LRTST=0 F S LRTST=$O(^LRO(69,LRCDT,1,LRSN,2,LRTST)) Q:LRTST<1 Q:'$P(^(LRTST,0),U,11)
109 . . Q:'LRTST S LREN5=^LRO(69,LRCDT,1,LRSN,2,LRTST,0)
110 . . S LRAA=$S($G(^LAB(69.9,1,14,LRIN,20)):+^(20),1:LRDAA)
111 . . S LRCTM=$P(LREDT,".",2)
112 . . S LRTS=+LREN5,LRCNT=1,LRLD="CP"
113 . . S (LRMA,LRLSS,LRWA)=LRAA
114 . . S LRACC=$P($G(^LRO(68,+$P(LREN5,U,4),1,+$P(LREN5,U,3),1,+$P(LREN5,U,5),.2)),U)
115 . . S LRFILE=+DFN_";DPT(",LROAD=$P(LREN5,U,3)
116 . . S LROAD1=$P(NODE,U,5),LROAD2=LRSN
117 . . S:'$G(LRSPEC) LRSPEC=$P($G(^LAB(69.9,1,1)),U)
118 . . S LRRRL=$P(NODE,U,7)
119 . . S LRRRL1=$P(NODE,U,6)
120 . . S LRRRL3=$P(NODE,U,2)
121 . . S LRIDT="",LRUG=$P(LREN5,U,2)
122 . . S LRTEC=$P(NODE,U,2)
123 . . D STORE^LRCAPV3
124 . S LRCEXV=LRCEX
125 S:'$G(LRDBUG) $P(^LRO(69,LRCDT,1,LRSN,0),U,10)=1 Q
126 Q
127EN3 ;Called from LRCAPPH
128 Q:'$G(LRVSIT) I $G(LRPCEON) D:$G(LRPKG) EN3^LRCAPPH1
129 Q ; EN3^SDACS is no longer supported
130 Q:$G(LRVSIT)=1
131 K SDERR D
132 . S LOC=$G(^SC(+$P(NODE,U,9),0))
133 . I $L(LOC),"CMZ"[$P(LOC,U,3) D
134 .. S SDC=LRSDC,SDMSG=$S('$D(ZTQUEUED):"S",1:0),SDCTYPE="S"
135 .. S SDIV=LRIN,SDATE=LRNT,SDUZ=$P(NODE,U,2) D:SDUZ EN3^SDACS
136 Q
137XTMP ;Clean up XTMP("LRCAP" global
138 ; Called from LRNIGHT
139 S LRCSQ="" F S LRCSQ=$O(^XTMP("LRCAP",LRCSQ)) Q:LRCSQ="" D
140 . S LRDUZ=0 F S LRDUZ=$O(^XTMP("LRCAP",LRCSQ,LRDUZ)) Q:LRDUZ<1 D QC K ^XTMP("LRCAP",LRCSQ)
141 K LRDUZ
142 Q
143QC ;
144 I $D(ZTQUEUED) S ZTREQ="@"
145 L +^XTMP("LRCAP",LRCSQ,LRDUZ):1 Q:'$T
146 S NODE=$G(^XTMP("LRCAP",LRCSQ,LRDUZ)) G:'$L(NODE) QUIT
147 S LRSTDC=+NODE,LRCQC=+$P(NODE,U,2),LRREPC=+$P(NODE,U,3),LRCDT=DT,LRIN=$S($G(DUZ(2)):DUZ(2),1:$$INSN^LRU)
148 S LRCC=0 F S LRCC=$O(^XTMP("LRCAP",LRCSQ,LRDUZ,LRCC)) Q:'LRCC I $D(^LAM(LRCC,0)) S LRWT=$P(^(0),U,3) D BLDIN^LRCAPV3 S:'$D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,0)) ^(0)=LRCC_U_LRWT D SET1 L
149QUIT K ^XTMP("LRCAP",LRCSQ,LRDUZ),NODE,LRSTDC,LRCQC,LRREPC,LRCC,LRWT,LRCSC,LRPKG
150 K ^TMP("LRPXAPI",$J),^TMP("LRMOD",$J)
151 L -^XTMP("LRCAP",LRCSQ,LRDUZ) Q
152SET1 F L +^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S"):10 Q:$T
153 G:'$D(LRSTDC)!('$D(LRCQC))!('$D(LRREPC)) SET2
154 I '$D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")) S ^("S")=LRSTDC_U_LRCQC_U_LRREPC_U G SET2
155 S NODE=$G(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")) I LRSTDC S $P(NODE,U)=$P(NODE,U)+LRSTDC
156 I LRREPC S $P(NODE,U,3)=$P(NODE,U,3)+LRREPC
157 I LRCQC S $P(NODE,U,2)=$P(NODE,U,2)+LRCQC
158 S ^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")=NODE
159SET2 L -^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")
160 Q
Note: See TracBrowser for help on using the repository browser.