LRCAPPH ;DALOI/VA/FHS - PROCESS PHLEBOTOMY WORKLOAD DATA ; 04-Apr-2016 07:38 ; MKK
;;5.2;LAB SERVICE;**1,19,127,136,1004,138,158,1009,153,263,264,1018,1019,1033,388**;NOV 01, 1997;Build 32
;
; Original Line 1: DALOI/FHS - PROCESS PHLEBOTOMY WORKLOAD DATA ; 5/1/99
;
;**DBIA 1995-A Retrieve CPT codes
;**DBIA 1995-B Retrieve CPT Modifiers
;**DBIA 1889-A Pass PCE Encounter Data
;**DBIA 1889-B Delete PCE Entries
;**DBIA 1889-F Extract PCE Data
; Reference to ^DIC(9.4, Supported by Reference 10048
; Reference to ^SC( Supported by Reference 10040
; Reference to ^%ZOSF("TEST") Supported by Reference #10096
; Reference to ^DIC(40.7 Supported by Reference #923
; Reference to ^XMB(1 Supported by Reference #10091
; Reference to T0^%ZOSV Supported by Reference #10097
; Reference to T1^%ZOSV Supported by Reference #10097
; Reference to ^DIC( Supported by Reference #10006
; Reference to EN3^SDACS Supported by DBIA #10041
; No longer called
; Reference to $$PKGON^VSIT Supported by DBIA #1900-E
; Reference to $$NOW^XLFDT Supported by Reference #10103
; Reference to $$GET^XUA4A72 Supported by Reference #1625
EN ;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
; I $G(^LRO(69,"AE"))'=DT D
; . D EN0^LRCAPPH3
; . S ^LRO(69,"AE")=DT
NP ;Not performed entry tag Called from LRCAPPNP
; N LRSPEC,LR657,LR658
; D
; . K DIC S DIC="^LAM(",DIC(0)="ONMX"
; . S X="89343.0000",LR657=657 D ^DIC I Y>1 S LR657=+Y
; . S X="89341.0000",LR658=658 D ^DIC I Y>1 S LR658=+Y
; K ^LRO(69,"AE",0)
; I $G(LRNP) S LRNOPX=1
I $D(ZTQUEUED) S ZTREQ="@" K LRDBUG
I '$G(LRDBUG) K ^TMP("LRMOD",$J)
S LRDPRAC=+$P($G(^LAB(69.9,1,12)),U)
I LRDPRAC D
. N DIC,X
. S DIC(0)="NZ",DIC=200,X="`"_LRDPRAC
. D ^DIC S LRDPRAC=$S(Y<1:0,$P($G(Y(0)),U,11):0,1:+Y)
. I $$GET^XUA4A72(LRDPRAC)<1 S LRDPRAC=0
S LROK=+$G(^LAB(69.9,1,.8)) G:'LROK END0
I $P($G(^SC(LROK,0)),U)'["LAB DIV " G END0
K LROK
I '$G(LRNP) L +^LRO("LRCAPPH","NITE"):1 G:'$T END0
S:'$D(^LAB(69.9,1,"NITE")) ^("NITE")=""
S LRWRKL=$S($P(^LAB(69.9,1,0),U,14):1,1:0)
I $D(XRTL) S XRTN="LRCAPPH" D T0^%ZOSV
S LRPKG=$O(^DIC(9.4,"C","LR",0))
S:'LRPKG LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
G:'LRPKG END0
S LRVSIT=$P($G(^LAB(69.9,1,"VSIT")),U)
;IHS/DIR/FJE 9/15/99
;COMMENTED LINE OUT
; S X="PXAI" X ^%ZOSF("TEST") I '$T G END0
;----- END IHS MODIFICATIONS LR*5.2*1018
;
S:'$G(LRNP) $P(^LAB(69.9,1,"NITE"),U,2)=$$NOW^XLFDT
; S LRPCEON=$$PKGON^VSIT("PX")
;----- BEGIN IHS MODIFICATIONS LR *5.2*1018
S X="VSIT" X ^%ZOSF("TEST") I $T S LRPCEON=$$PKGON^VSIT("PX")
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S LRPCEON=0 ;IHS/DIR/FJE 9/15/99
;----- END IHS MODIFICATIONS
S ^TMP("LRMOD",$J)=""
;
SDC ; 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)
;----- BEGIN IHS MODIFICATION LR*5.2*1018
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)
;----- END IHS MODIFICATION REMOVE + AS CLINIC CODES CHANGED FROM NUMERIC TO ALPHA WITH MAS 5.0 patch 8 (ALSO PIMS)
;
DSSLOC S LRDLOC=+$G(^LAB(69.9,1,.8))
;----- BEGIN IHS MODIFICATION LR*5.2*1019
; N LR657,LR658 ; IHS/MSC/MKK - LR*5.2*1033 = Commented out NEW
; Added following code, which is commented out above, due to <UNDEFINED> error at Browning (MT)
; If the process ever gets to this point, then LR657 and LR658 MUST BE defined.
I $G(LR658)=""!($G(LR657)="") D
. K DIC S DIC="^LAM(",DIC(0)="ONMX"
. S X="89343.0000",LR657=657 D ^DIC I Y>1 S LR657=+Y
. S X="89341.0000",LR658=658 D ^DIC I Y>1 S LR658=+Y
;----- END IHS MODIFICATION LR*5.2*1019
;
S LCWT=$P($G(^LAM(LR658,0)),U,3)_U_$P($G(^LAM(LR658,0)),U,10)
S LSPWT=$P($G(^LAM(LR657,0)),U,3)_U_$P($G(^LAM(LR657,0)),U,10)
S LRCSC=+$G(^LAB(69.9,1,"VSIT"))
S LRINS=+$P($G(^XMB(1,1,"XUS")),U,17) G END0:'LRINS
HEAC ;
D
. N DIC,Y,X
. S DIC="^LRO(68,",DIC(0)="MO",X="HEM" D ^DIC
. I Y>0 S LRDAA=+Y Q
. S LRDAA=10
S LRSPEC=$P($G(^LAB(69.9,1,1)),U)
I $G(LRNP) S LRNOPX=0 Q
S (LRCEX,LRCEXV,LREND,LROA)=0 F S LRCEX=$O(^LRO(69,"AA",LRCEX)) Q:LRCEX=""!(LREND) D
. K LRXCPT
. 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
. . I '$G(LRDBUG) K:'$G(^LRO(69,"AA",LRCEX,LROA)) ^(LROA)
AE ;Process NP specimens and delete CPT procedures
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;K LRXCPT D ^LRCAPPNP
;COMMENT OUT UNTIL CPT VA UPDATE TO CPTV6.0 IS COMPLETE
;----- END IHS MODIFICATIONS
END0 Q:$G(LRDBUG)
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
K LRVSIT,EDATE,^TMP("LRPXAPI",$J),LRPCEON,DFN,LRCE,LRCSQ,SDUZ,EDATE
K LRCEX,LRCEXV,CPT,LRNINS,LRCDT,LREDT,LRCNT,LRI,LRICPT,LRINA,LRNLT,LRPKG
K LRREL,LRSN,LRSTP,LRTST,LRTSTP,LRVSIT,NODE,LRPRO
K LRDLOC,LRDSSLOC,LRNOP,SDERR,PXKDONE,VSIT,DIC,LRCSC,LRDFN
K LRDPRAC,LROK,LRXCPT
K ^TMP("LRMOD",$J)
I $D(XRT0) S XRTN="END^LRCAPPH" D T1^%ZOSV
S $P(^LAB(69.9,1,"NITE"),U,2)="" L -^LRO("LRCAPPH","NITE")
Q
LOOK ;From LRCAPPNP
N LRDUZ
Q:'$D(^LRO(69,LRCDT,1,LRSN,0))#2 S NODE=^(0)
S LRDFN=+NODE Q:'$D(^LR(LRDFN,0))#2 S LRDPF=+$P(^(0),U,2),DFN=+$P(^(0),U,3)
Q:'DFN!(LRDPF'=2)
S LRDUZ=$S($P(NODE,U,2):$P(NODE,U,2),1:DUZ)
S LRCC=$S(($P(NODE,U,4)="LC"!($P(NODE,U,4)="I")):LR658,$P(NODE,U,4)="SP":LR657,1:0)
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))
I $G(LRNP) S LRNOPX=1 Q
D:LRCSC EN3 I 'LRWRKL S:'$G(LRDBUG) $P(^LRO(69,LRCDT,1,LRSN,0),U,10)=1,LRCEXV=$G(LRCEX) Q
Q:$G(^LRO(69,"AA",LRCEX,LROA))
PHLE I $G(LRCC),LRCEX'=$G(LRCEXV) D
. S LREDT=$P($G(^LRO(69,LRCDT,1,LRSN,3)),U) Q:'LREDT
. S LRCDTSAV=LRCDT
. N LRCDT,LRIN,DIC,X,Y
. S X="`"_$P(NODE,U,9),DIC="^SC(",DIC(0)="NZ" D ^DIC
. Q:Y<1
. S:Y>0 LROL=+Y,LRIN=$P(Y(0),U,4),LRRRL2=$P(Y(0),U,20),LRRRL4=$P(Y(0),U,3)
. S:'LRIN LRIN=LRINS
. S LRCDT=$P(LREDT,".")
. D:'$D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,0))#2 BLDIN^LRCAPV3
. D
. . S LRTST=0 F S LRTST=$O(^LRO(69,LRCDTSAV,1,LRSN,2,LRTST)) Q:LRTST<1 Q:'$P(^(LRTST,0),U,11)
. . Q:'LRTST S LREN5=^LRO(69,LRCDTSAV,1,LRSN,2,LRTST,0)
. . S LRAA=$S($G(^LAB(69.9,1,14,LRIN,20)):+^(20),1:LRDAA)
. . S LRCTM=$P(LREDT,".",2)
. . S LRTS=+LREN5,LRCNT=1,LRLD="CP"
. . S (LRMA,LRLSS,LRWA)=LRAA
. . S LRACC=$P($G(^LRO(68,+$P(LREN5,U,4),1,+$P(LREN5,U,3),1,+$P(LREN5,U,5),.2)),U)
. . S LRFILE=+DFN_";DPT(",LROAD=$P(LREN5,U,3)
. . S LROAD1=$P(NODE,U,5),LROAD2=LRSN
. . S:'$G(LRSPEC) LRSPEC=$P($G(^LAB(69.9,1,1)),U)
. . S LRRRL=$P(NODE,U,7)
. . S LRRRL1=$P(NODE,U,6)
. . S LRRRL3=$P(NODE,U,2)
. . S LRIDT="",LRUG=$P(LREN5,U,2)
. . S LRTEC=$P(NODE,U,2)
. . D STORE^LRCAPV3
. . K LRCDTSAV
. S LRCEXV=LRCEX
S:'$G(LRDBUG) $P(^LRO(69,LRCDT,1,LRSN,0),U,10)=1 Q
Q
EN3 ;Called from LRCAPPH
Q:'$G(LRVSIT) I $G(LRPCEON) D:$G(LRPKG) EN3^LRCAPPH1
Q ; EN3^SDACS is no longer supported
Q:$G(LRVSIT)=1
K SDERR D
. S LOC=$G(^SC(+$P(NODE,U,9),0))
. I $L(LOC),"CMZ"[$P(LOC,U,3) D
.. S SDC=LRSDC,SDMSG=$S('$D(ZTQUEUED):"S",1:0),SDCTYPE="S"
.. S SDIV=LRIN,SDATE=LRNT,SDUZ=$P(NODE,U,2) D:SDUZ EN3^SDACS
Q
XTMP ;Clean up XTMP("LRCAP" global
; Called from LRNIGHT
S LRCSQ="" F S LRCSQ=$O(^XTMP("LRCAP",LRCSQ)) Q:LRCSQ="" D
. S LRDUZ=0 F S LRDUZ=$O(^XTMP("LRCAP",LRCSQ,LRDUZ)) Q:LRDUZ<1 D QC K ^XTMP("LRCAP",LRCSQ)
K LRDUZ
Q
QC ;
I $D(ZTQUEUED) S ZTREQ="@"
L +^XTMP("LRCAP",LRCSQ,LRDUZ):1 Q:'$T
S NODE=$G(^XTMP("LRCAP",LRCSQ,LRDUZ)) G:'$L(NODE) QUIT
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)
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
QUIT K ^XTMP("LRCAP",LRCSQ,LRDUZ),NODE,LRSTDC,LRCQC,LRREPC,LRCC,LRWT,LRCSC,LRPKG
K ^TMP("LRPXAPI",$J),^TMP("LRMOD",$J)
L -^XTMP("LRCAP",LRCSQ,LRDUZ) Q
SET1 F L +^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S"):10 Q:$T
G:'$D(LRSTDC)!('$D(LRCQC))!('$D(LRREPC)) SET2
I '$D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")) S ^("S")=LRSTDC_U_LRCQC_U_LRREPC_U G SET2
S NODE=$G(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")) I LRSTDC S $P(NODE,U)=$P(NODE,U)+LRSTDC
I LRREPC S $P(NODE,U,3)=$P(NODE,U,3)+LRREPC
I LRCQC S $P(NODE,U,2)=$P(NODE,U,2)+LRCQC
S ^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")=NODE
SET2 L -^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")
Q
LRCAPPH ;DALOI/VA/FHS - PROCESS PHLEBOTOMY WORKLOAD DATA ; 04-Apr-2016 07:38 ; MKK
+1 ;;5.2;LAB SERVICE;**1,19,127,136,1004,138,158,1009,153,263,264,1018,1019,1033,388**;NOV 01, 1997;Build 32
+2 ;
+3 ; Original Line 1: DALOI/FHS - PROCESS PHLEBOTOMY WORKLOAD DATA ; 5/1/99
+4 ;
+5 ;**DBIA 1995-A Retrieve CPT codes
+6 ;**DBIA 1995-B Retrieve CPT Modifiers
+7 ;**DBIA 1889-A Pass PCE Encounter Data
+8 ;**DBIA 1889-B Delete PCE Entries
+9 ;**DBIA 1889-F Extract PCE Data
+10 ; Reference to ^DIC(9.4, Supported by Reference 10048
+11 ; Reference to ^SC( Supported by Reference 10040
+12 ; Reference to ^%ZOSF("TEST") Supported by Reference #10096
+13 ; Reference to ^DIC(40.7 Supported by Reference #923
+14 ; Reference to ^XMB(1 Supported by Reference #10091
+15 ; Reference to T0^%ZOSV Supported by Reference #10097
+16 ; Reference to T1^%ZOSV Supported by Reference #10097
+17 ; Reference to ^DIC( Supported by Reference #10006
+18 ; Reference to EN3^SDACS Supported by DBIA #10041
+19 ; No longer called
+20 ; Reference to $$PKGON^VSIT Supported by DBIA #1900-E
+21 ; Reference to $$NOW^XLFDT Supported by Reference #10103
+22 ; Reference to $$GET^XUA4A72 Supported by Reference #1625
EN ;
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ; I $G(^LRO(69,"AE"))'=DT D
+3 ; . D EN0^LRCAPPH3
+4 ; . S ^LRO(69,"AE")=DT
NP ;Not performed entry tag Called from LRCAPPNP
+1 ; N LRSPEC,LR657,LR658
+2 ; D
+3 ; . K DIC S DIC="^LAM(",DIC(0)="ONMX"
+4 ; . S X="89343.0000",LR657=657 D ^DIC I Y>1 S LR657=+Y
+5 ; . S X="89341.0000",LR658=658 D ^DIC I Y>1 S LR658=+Y
+6 ; K ^LRO(69,"AE",0)
+7 ; I $G(LRNP) S LRNOPX=1
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL LRDBUG
+9 IF '$GET(LRDBUG)
KILL ^TMP("LRMOD",$JOB)
+10 SET LRDPRAC=+$PIECE($GET(^LAB(69.9,1,12)),U)
+11 IF LRDPRAC
Begin DoDot:1
+12 NEW DIC,X
+13 SET DIC(0)="NZ"
SET DIC=200
SET X="`"_LRDPRAC
+14 DO ^DIC
SET LRDPRAC=$SELECT(Y<1:0,$PIECE($GET(Y(0)),U,11):0,1:+Y)
+15 IF $$GET^XUA4A72(LRDPRAC)<1
SET LRDPRAC=0
End DoDot:1
+16 SET LROK=+$GET(^LAB(69.9,1,.8))
IF 'LROK
GOTO END0
+17 IF $PIECE($GET(^SC(LROK,0)),U)'["LAB DIV "
GOTO END0
+18 KILL LROK
+19 IF '$GET(LRNP)
LOCK +^LRO("LRCAPPH","NITE"):1
IF '$TEST
GOTO END0
+20 IF '$DATA(^LAB(69.9,1,"NITE"))
SET ^("NITE")=""
+21 SET LRWRKL=$SELECT($PIECE(^LAB(69.9,1,0),U,14):1,1:0)
+22 IF $DATA(XRTL)
SET XRTN="LRCAPPH"
DO T0^%ZOSV
+23 SET LRPKG=$ORDER(^DIC(9.4,"C","LR",0))
+24 IF 'LRPKG
SET LRPKG=$ORDER(^DIC(9.4,"B","LAB SERVICE",0))
+25 IF 'LRPKG
GOTO END0
+26 SET LRVSIT=$PIECE($GET(^LAB(69.9,1,"VSIT")),U)
+27 ;IHS/DIR/FJE 9/15/99
+28 ;COMMENTED LINE OUT
+29 ; S X="PXAI" X ^%ZOSF("TEST") I '$T G END0
+30 ;----- END IHS MODIFICATIONS LR*5.2*1018
+31 ;
+32 IF '$GET(LRNP)
SET $PIECE(^LAB(69.9,1,"NITE"),U,2)=$$NOW^XLFDT
+33 ; S LRPCEON=$$PKGON^VSIT("PX")
+34 ;----- BEGIN IHS MODIFICATIONS LR *5.2*1018
+35 SET X="VSIT"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET LRPCEON=$$PKGON^VSIT("PX")
+36 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+37 ;IHS/DIR/FJE 9/15/99
SET LRPCEON=0
+38 ;----- END IHS MODIFICATIONS
+39 SET ^TMP("LRMOD",$JOB)=""
+40 ;
SDC ; 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)
+1 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+2 SET SDC=$SELECT($PIECE(^LAB(69.9,1,"NITE"),U,3):$GET(^DIC(40.7,$PIECE(^LAB(69.9,1,"NITE"),U,3),0)),1:"")
SET LRSDC=$SELECT($PIECE(SDC,U,2):+$PIECE(SDC,U,2),1:108)
+3 ;----- END IHS MODIFICATION REMOVE + AS CLINIC CODES CHANGED FROM NUMERIC TO ALPHA WITH MAS 5.0 patch 8 (ALSO PIMS)
+4 ;
DSSLOC SET LRDLOC=+$GET(^LAB(69.9,1,.8))
+1 ;----- BEGIN IHS MODIFICATION LR*5.2*1019
+2 ; N LR657,LR658 ; IHS/MSC/MKK - LR*5.2*1033 = Commented out NEW
+3 ; Added following code, which is commented out above, due to <UNDEFINED> error at Browning (MT)
+4 ; If the process ever gets to this point, then LR657 and LR658 MUST BE defined.
+5 IF $GET(LR658)=""!($GET(LR657)="")
Begin DoDot:1
+6 KILL DIC
SET DIC="^LAM("
SET DIC(0)="ONMX"
+7 SET X="89343.0000"
SET LR657=657
DO ^DIC
IF Y>1
SET LR657=+Y
+8 SET X="89341.0000"
SET LR658=658
DO ^DIC
IF Y>1
SET LR658=+Y
End DoDot:1
+9 ;----- END IHS MODIFICATION LR*5.2*1019
+10 ;
+11 SET LCWT=$PIECE($GET(^LAM(LR658,0)),U,3)_U_$PIECE($GET(^LAM(LR658,0)),U,10)
+12 SET LSPWT=$PIECE($GET(^LAM(LR657,0)),U,3)_U_$PIECE($GET(^LAM(LR657,0)),U,10)
+13 SET LRCSC=+$GET(^LAB(69.9,1,"VSIT"))
+14 SET LRINS=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
IF 'LRINS
GOTO END0
HEAC ;
+1 Begin DoDot:1
+2 NEW DIC,Y,X
+3 SET DIC="^LRO(68,"
SET DIC(0)="MO"
SET X="HEM"
DO ^DIC
+4 IF Y>0
SET LRDAA=+Y
QUIT
+5 SET LRDAA=10
End DoDot:1
+6 SET LRSPEC=$PIECE($GET(^LAB(69.9,1,1)),U)
+7 IF $GET(LRNP)
SET LRNOPX=0
QUIT
+8 SET (LRCEX,LRCEXV,LREND,LROA)=0
FOR
SET LRCEX=$ORDER(^LRO(69,"AA",LRCEX))
IF LRCEX=""!(LREND)
QUIT
Begin DoDot:1
+9 KILL LRXCPT
+10 SET (LROA,LRCC)=""
FOR
SET LROA=$ORDER(^LRO(69,"AA",LRCEX,LROA))
IF LROA=""
QUIT
SET LRCDT=+LROA
SET LRSN=+$PIECE(LROA,"|",2)
IF LRCDT&(LRSN)
DO LOOK
Begin DoDot:2
+11 IF '$GET(LRDBUG)
IF '$GET(^LRO(69,"AA",LRCEX,LROA))
KILL ^(LROA)
End DoDot:2
End DoDot:1
AE ;Process NP specimens and delete CPT procedures
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;K LRXCPT D ^LRCAPPNP
+3 ;COMMENT OUT UNTIL CPT VA UPDATE TO CPTV6.0 IS COMPLETE
+4 ;----- END IHS MODIFICATIONS
END0 IF $GET(LRDBUG)
QUIT
+1 KILL 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
+2 KILL LRVSIT,EDATE,^TMP("LRPXAPI",$JOB),LRPCEON,DFN,LRCE,LRCSQ,SDUZ,EDATE
+3 KILL LRCEX,LRCEXV,CPT,LRNINS,LRCDT,LREDT,LRCNT,LRI,LRICPT,LRINA,LRNLT,LRPKG
+4 KILL LRREL,LRSN,LRSTP,LRTST,LRTSTP,LRVSIT,NODE,LRPRO
+5 KILL LRDLOC,LRDSSLOC,LRNOP,SDERR,PXKDONE,VSIT,DIC,LRCSC,LRDFN
+6 KILL LRDPRAC,LROK,LRXCPT
+7 KILL ^TMP("LRMOD",$JOB)
+8 IF $DATA(XRT0)
SET XRTN="END^LRCAPPH"
DO T1^%ZOSV
+9 SET $PIECE(^LAB(69.9,1,"NITE"),U,2)=""
LOCK -^LRO("LRCAPPH","NITE")
+10 QUIT
LOOK ;From LRCAPPNP
+1 NEW LRDUZ
+2 IF '$DATA(^LRO(69,LRCDT,1,LRSN,0))#2
QUIT
SET NODE=^(0)
+3 SET LRDFN=+NODE
IF '$DATA(^LR(LRDFN,0))#2
QUIT
SET LRDPF=+$PIECE(^(0),U,2)
SET DFN=+$PIECE(^(0),U,3)
+4 IF 'DFN!(LRDPF'=2)
QUIT
+5 SET LRDUZ=$SELECT($PIECE(NODE,U,2):$PIECE(NODE,U,2),1:DUZ)
+6 SET LRCC=$SELECT(($PIECE(NODE,U,4)="LC"!($PIECE(NODE,U,4)="I")):LR658,$PIECE(NODE,U,4)="SP":LR657,1:0)
+7 IF '$DATA(^LRO(69,LRCDT,1,LRSN,1))#2
QUIT
SET NODE(1)=^(1)
IF $PIECE(NODE(1),U,4)'="C"
QUIT
SET LRNT=+NODE(1)
SET LRIN=$SELECT($PIECE(NODE(1),U,8):$PIECE(NODE(1),U,8),1:LRINS)
SET LRCE=+$GET(^(.1))
+8 IF $GET(LRNP)
SET LRNOPX=1
QUIT
+9 IF LRCSC
DO EN3
IF 'LRWRKL
IF '$GET(LRDBUG)
SET $PIECE(^LRO(69,LRCDT,1,LRSN,0),U,10)=1
SET LRCEXV=$GET(LRCEX)
QUIT
+10 IF $GET(^LRO(69,"AA",LRCEX,LROA))
QUIT
PHLE IF $GET(LRCC)
IF LRCEX'=$GET(LRCEXV)
Begin DoDot:1
+1 SET LREDT=$PIECE($GET(^LRO(69,LRCDT,1,LRSN,3)),U)
IF 'LREDT
QUIT
+2 SET LRCDTSAV=LRCDT
+3 NEW LRCDT,LRIN,DIC,X,Y
+4 SET X="`"_$PIECE(NODE,U,9)
SET DIC="^SC("
SET DIC(0)="NZ"
DO ^DIC
+5 IF Y<1
QUIT
+6 IF Y>0
SET LROL=+Y
SET LRIN=$PIECE(Y(0),U,4)
SET LRRRL2=$PIECE(Y(0),U,20)
SET LRRRL4=$PIECE(Y(0),U,3)
+7 IF 'LRIN
SET LRIN=LRINS
+8 SET LRCDT=$PIECE(LREDT,".")
+9 IF '$DATA(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,0))#2
DO BLDIN^LRCAPV3
+10 Begin DoDot:2
+11 SET LRTST=0
FOR
SET LRTST=$ORDER(^LRO(69,LRCDTSAV,1,LRSN,2,LRTST))
IF LRTST<1
QUIT
IF '$PIECE(^(LRTST,0),U,11)
QUIT
+12 IF 'LRTST
QUIT
SET LREN5=^LRO(69,LRCDTSAV,1,LRSN,2,LRTST,0)
+13 SET LRAA=$SELECT($GET(^LAB(69.9,1,14,LRIN,20)):+^(20),1:LRDAA)
+14 SET LRCTM=$PIECE(LREDT,".",2)
+15 SET LRTS=+LREN5
SET LRCNT=1
SET LRLD="CP"
+16 SET (LRMA,LRLSS,LRWA)=LRAA
+17 SET LRACC=$PIECE($GET(^LRO(68,+$PIECE(LREN5,U,4),1,+$PIECE(LREN5,U,3),1,+$PIECE(LREN5,U,5),.2)),U)
+18 SET LRFILE=+DFN_";DPT("
SET LROAD=$PIECE(LREN5,U,3)
+19 SET LROAD1=$PIECE(NODE,U,5)
SET LROAD2=LRSN
+20 IF '$GET(LRSPEC)
SET LRSPEC=$PIECE($GET(^LAB(69.9,1,1)),U)
+21 SET LRRRL=$PIECE(NODE,U,7)
+22 SET LRRRL1=$PIECE(NODE,U,6)
+23 SET LRRRL3=$PIECE(NODE,U,2)
+24 SET LRIDT=""
SET LRUG=$PIECE(LREN5,U,2)
+25 SET LRTEC=$PIECE(NODE,U,2)
+26 DO STORE^LRCAPV3
+27 KILL LRCDTSAV
End DoDot:2
+28 SET LRCEXV=LRCEX
End DoDot:1
+29 IF '$GET(LRDBUG)
SET $PIECE(^LRO(69,LRCDT,1,LRSN,0),U,10)=1
QUIT
+30 QUIT
EN3 ;Called from LRCAPPH
+1 IF '$GET(LRVSIT)
QUIT
IF $GET(LRPCEON)
IF $GET(LRPKG)
DO EN3^LRCAPPH1
+2 ; EN3^SDACS is no longer supported
QUIT
+3 IF $GET(LRVSIT)=1
QUIT
+4 KILL SDERR
Begin DoDot:1
+5 SET LOC=$GET(^SC(+$PIECE(NODE,U,9),0))
+6 IF $LENGTH(LOC)
IF "CMZ"[$PIECE(LOC,U,3)
Begin DoDot:2
+7 SET SDC=LRSDC
SET SDMSG=$SELECT('$DATA(ZTQUEUED):"S",1:0)
SET SDCTYPE="S"
+8 SET SDIV=LRIN
SET SDATE=LRNT
SET SDUZ=$PIECE(NODE,U,2)
IF SDUZ
DO EN3^SDACS
End DoDot:2
End DoDot:1
+9 QUIT
XTMP ;Clean up XTMP("LRCAP" global
+1 ; Called from LRNIGHT
+2 SET LRCSQ=""
FOR
SET LRCSQ=$ORDER(^XTMP("LRCAP",LRCSQ))
IF LRCSQ=""
QUIT
Begin DoDot:1
+3 SET LRDUZ=0
FOR
SET LRDUZ=$ORDER(^XTMP("LRCAP",LRCSQ,LRDUZ))
IF LRDUZ<1
QUIT
DO QC
KILL ^XTMP("LRCAP",LRCSQ)
End DoDot:1
+4 KILL LRDUZ
+5 QUIT
QC ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 LOCK +^XTMP("LRCAP",LRCSQ,LRDUZ):1
IF '$TEST
QUIT
+3 SET NODE=$GET(^XTMP("LRCAP",LRCSQ,LRDUZ))
IF '$LENGTH(NODE)
GOTO QUIT
+4 SET LRSTDC=+NODE
SET LRCQC=+$PIECE(NODE,U,2)
SET LRREPC=+$PIECE(NODE,U,3)
SET LRCDT=DT
SET LRIN=$SELECT($GET(DUZ(2)):DUZ(2),1:$$INSN^LRU)
+5 SET LRCC=0
FOR
SET LRCC=$ORDER(^XTMP("LRCAP",LRCSQ,LRDUZ,LRCC))
IF 'LRCC
QUIT
IF $DATA(^LAM(LRCC,0))
SET LRWT=$PIECE(^(0),U,3)
DO BLDIN^LRCAPV3
IF '$DATA(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,0))
SET ^(0)=LRCC_U_LRWT
DO SET1
LOCK
QUIT KILL ^XTMP("LRCAP",LRCSQ,LRDUZ),NODE,LRSTDC,LRCQC,LRREPC,LRCC,LRWT,LRCSC,LRPKG
+1 KILL ^TMP("LRPXAPI",$JOB),^TMP("LRMOD",$JOB)
+2 LOCK -^XTMP("LRCAP",LRCSQ,LRDUZ)
QUIT
SET1 FOR
LOCK +^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S"):10
IF $TEST
QUIT
+1 IF '$DATA(LRSTDC)!('$DATA(LRCQC))!('$DATA(LRREPC))
GOTO SET2
+2 IF '$DATA(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S"))
SET ^("S")=LRSTDC_U_LRCQC_U_LRREPC_U
GOTO SET2
+3 SET NODE=$GET(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S"))
IF LRSTDC
SET $PIECE(NODE,U)=$PIECE(NODE,U)+LRSTDC
+4 IF LRREPC
SET $PIECE(NODE,U,3)=$PIECE(NODE,U,3)+LRREPC
+5 IF LRCQC
SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)+LRCQC
+6 SET ^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")=NODE
SET2 LOCK -^LRO(64.1,LRIN,1,LRCDT,1,LRCC,"S")
+1 QUIT
