LRCAPES ;DALOI/FHS/KLL -MANUAL PCE CPT WORKLOAD CAPTURE ; 22-Oct-2013 09:22 ; MKK
;;5.2;LAB SERVICE;**274,1018,259,1030,349,308,1031,1033**;NOV 1, 1997
;
;Reference to $$GET^XUA4A72 - Supported by DBIA #1625
EN ; EP
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
D EN^LRCAPES1
Q
;
EX1 ;Parse the read entry
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N LRXY,LRACTV,LRXY1,LRXY2,LRD2,LRNR,LRWL2,LRINA2,LRREL2,LRQ
Q:'$L($G(LRX))
;Edit on 5-digit code entry
I LRX?5N,'$D(^TMP("LR",$J,"AK",LRX))#2 D Q
.S LRXY=$$CPT^ICPTCOD(LRX,DT)
.D CHKCPT^LRCAPES1
.;Don't pass to PCE if CPT is missing or inactive in #81 or #64
.Q:'$P(LRXY,U,7)!(LRNR)
.;If CPT is inactive in #64 and another active CPT exists, replace
.; the inactive with the active CPT
.I LRACTV D Q
..S LRXY=$$CPT^ICPTCOD(LRXY2,DT)
..S LRCNT=+$G(LRCNT)+1
..S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_U_LRWL2_U_$P(LRXY,U,3)_U
..S LRRF64=$S($G(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
..;If CPT passes edits, continue
.S LRCNT=+$G(LRCNT)+1
.S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_"^^"_$P(LRXY,U,3)_U
;Edit on ES Display Order # entry
S LRQ="^TMP(""LR"","_$J_",""AK"","_LRX_")"
S LRQ=$Q(@LRQ)
S LRXY=$$CPT^ICPTCOD($QS(LRQ,6),DT)
D CHKCPT^LRCAPES1
Q:'$P(LRXY,U,7)!(LRNR)
;If CPT is inactive in #64 and another active CPT exists, replace
; the inactive with the active CPT
I LRACTV D Q
.S LRXY=$$CPT^ICPTCOD(LRXY2,DT)
.S LRCNT=+$G(LRCNT)+1
.S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_U_LRWL2_U_$P(LRXY,U,3)_U
.S LRRF64=$S($G(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
.;I CPT passes edits, continue
S LRCNT=+$G(LRCNT)+1
S ^TMP("LR",$J,"LRLST",LRCNT)=$QS(LRQ,6)_U_@LRQ
Q
;
END1 ;
D END S LREND=1
Q
;
END ;
I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
K:'$G(LRESCPT) ^TMP("LR",$J,"AK")
I $G(LRDEBUG) W !,"END ",! Q
Q
;
WLN ;Interactive entry point
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
D KVA^VADPT
;
K DIC,DIR
K LREND,LRUID,DIC,DIR,LRVBY
K ^TMP("LR",$J,"LRLST")
K LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LRIDT
K LRRB,LRSS,LRTIME,LRTREA,LRUID,LRWRD,PNM,SEX,SSN,AGE
S (LRAA,LRACC,LRAD,LRNOP,LRAN,LREND)=0,LRVBY=1,LRUID=""
S:'$G(LRPRO) LRPRO=DUZ
I '$G(LRESCPT) S LRVBY=$$SELBY^LRWU4("Select Accession By")
D:LRVBY=1 ^LRVERA D:LRVBY=2 UID^LRVERA
I 'LRVBY!(LRAA<1) D END S LREND=1 Q
S LRDFN=+$$GET1^DIQ(68.02,+$G(LRAN)_","_+$G(LRAD)_","_+$G(LRAA)_",",.01)
I 'LRDFN D END S LRNOP=1 D Q
. W !?5,"This accession is corrupt",!
;
LCK ;
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
L +^LRO(68,LRAA,1,LRAD,1,LRAN):10 I '$T D Q
. W !?5,"Someone else is editing this accession",!
. S LRNOP=1
D PT^LRX
S LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
S LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
S:$L($G(LRUID)) LRSPECID=LRSPECID_" UID: "_LRUID
S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
I LREDT'?7N.E D Q
. W !?5,"This accession does not have a Collection Date/Time",!
. W !?10,"CAN NOT PROCEED",!
. S LRNOP="6^Not Accessioned"
I '$G(LRIDT) S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
I '$L($G(LRSS)) S LRSS=$$GET1^DIQ(68,LRAA_",",.02,"I")
S LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
S LRDSSLOC=$S($G(LRDSSLOC):LRDSSLOC,1:LRDLOC)
D DEM^LRCAPES1
;
PRO ;Get provider,patient/location information
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
S LREND=0
D
. N LRPRONM,DIR,DIRUT,DUOUT,X,Y
. S LRPRONM=$$GET1^DIQ(200,+$G(LRPRO),.01,"I")
. I $L(LRPRONM),$D(^VA(200,"AK.PROVIDER",LRPRONM,+$G(LRPRO)))#2,$$GET^XUA4A72(+$G(LRPRO),DT)>0 S DIR("B")=LRPRONM
. ;S DIR("A")="Releasing Pathologist"
. S DIR("A")="Provider"
. S LRPRO=0,DIR(0)="PO^200:ENMZ"
. S DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
. D ^DIR
. I Y>1 S LRPRO=+Y
I '$G(LRPRO) D D END1 Q
. W !?5,"No Active Provider Selected",!
. S LRNOP=1
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 D D END1 G WLN
. W !?5,"The accession is corrupt - missing zero node",!
. S LRNOP="7^Corrupt Accession"
;
LOC ;Reporting Location
S LRNODE0=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
S LRNOP=0
S (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
I $L(LRLLOC) S LRLLOC=+$$FIND1^DIC(44,"","OM",LRLLOC)
;
ASKLOC ;Check to see if outpatient location
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
I '$D(^SC(+$G(LRLLOC),0))#2 D
. N DIR,X,Y
. S LRLLOC=""
. S DIR(0)="PO^44:AEZNMO",DIR("A")=" Ordering Location "
. D ^DIR
. I +Y<1 Q
. S LRLLOC=+Y
I '$G(LRLLOC) D END1 Q
S LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I") ;I 'LRDSSID S LRNOP="2^No Stop Code Number" Q
S LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
S LRNINS=$S(LRNINS:LRNINS,1:DUZ(2))
Q
;
ES() ; EP - Entry point for front end application.
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N DFN,LRESCPT,LRDFN,LRLLOC,LRLLOCX,LRNINS,LRTST,LRENCDT,LRDUZ
K LRES,LRESCPT
S LRES=1
;
ASK ; Option entry point - Check and setup PCE reporting variables
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
D EN^LRCAPES1
N X,Y,T1
S LREND=0
D ^LRPARAM Q:$G(LREND)
K ^TMP("LRPXAPI",$J),^TMP("LR",$J,"LRLST")
S ^TMP("LR",$J,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
S:'$G(LRPKG) LRPKG=$O(^DIC(9.4,"B","LR",0))
S:'$G(LRPKG) LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
;
PKG ;Check to see if Lab Package is installed
I '$G(LRPKG) D D WKL Q
. W !?5,"LAB SERVICE PACKAGE is not loaded",!
;
PCE ;Check to see if PCE is turned on
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
S X="PXAI" X ^%ZOSF("TEST") I '$T D:'$G(LRES) D WKL Q
. W !?5,"PCE Is not installed",!
S LRPCEON=$$PKGON^VSIT("PX")
I '$G(LRES),'LRPCEON D D WKL Q
. W !?5,"PCE is not turned on",!
S LRDLOC=+$$GET1^DIQ(69.9,"1,",.8,"I")
;
OOS ;Check to see if the LRDLOC is an OOS location
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
I $G(LRES),$P($G(^SC(LRDLOC,0)),U)'["LAB DIV " D D WKL Q
. W !?5,"DEFAULT LAB OOS LOCATION is not defined correctly",!
S LRESCPT=1
D:'$G(^TMP("LR",$J,"AK",0,1))'=DUZ_U_DT EN
I $G(LRES) Q $G(LRESCPT)
;
LOOP ;
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
Q:$G(LREND)
F D WLN Q:$G(LREND) I '$G(LRNOP) D CPTEN Q:$G(LREND)
D CLEAN Q
;
CPTEN ; EP - Entry point from CPT API call
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
;
WKL ; S (LRNOP,LREND)=0 D READ^LRCAPES1 ; IHS/MSC/MKK - LR*5.2*1033
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
S (LRNOP,LREND)=0 D READ^LRCAPES1
;
D DIS^LRCAPES1
I '$O(^TMP("LR",$J,"LRLST",0)) D END Q
;
LOAD ;Setup ^TMP("LRPXAPI" to load CPT workload
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
K LRXCPT,LRXTST,^TMP("LRPXAPI",$J)
;
S LRDUZ=LRPRO
I '$G(LRESCPT) S LRNOP="3^PCE Workload Capture Not Setup"
I $G(LRNOP) D D SENDWKL Q
. I '$D(LRQUIET) W !,$$CJ^XLFSTR("PCE Wkld Abort "_$P(LRNOP,U,2),IOM)
I $G(LRESCPT),'$G(LRNOP) D
. N AFTER812,D,D0,DDER,DI,DIC,DIG,DIH,DISL,DIV
. N I,LRACC,LRCNT,LRI,LRPCEN,PXALOOK,PXASUB,PXJ,PXJJ,LRCCT
. N SDT1,SPEL,SUBL,TYPEI,X,XPARSYS
. S LRTST=0
. F S LRTST=$O(^TMP("LR",$J,"LRLST",LRTST)) Q:LRTST<1 D
. . S (LRNLTN,CPT)=+$G(^TMP("LR",$J,"LRLST",LRTST)),LRTSTP=$P(^(LRTST),U,2,99)
. . D SET^LRCAPPH1
. D ADDPREV
;
SENDWKL ; Store LMIP workload
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
D SEND^LRCAPES1
L -^LRO(68,LRAA,1,LRAD,1,LRAN)
S LRNOP=0
Q
;
ADDPREV ;Add CPT quantities from PCE to current totals
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N LRSTR2,LRIEN2,LRPX,LRCPT,LRXX,LRCPT2,LRCPT1,LRX1,LRQ1,LRQ2,LRQT,LRCT
S LRSTR2=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
Q:'LRSTR2
K LRVIS S LRVIS=""
S LRCT=$L(LRSTR2,";")-1,LRVIS=$P(LRSTR2,";",LRCT)
F LRPX=1:1 S LRIEN2=$P(LRSTR2,";",LRPX) Q:LRIEN2="" D
.D GETCPT^PXAPIOE(LRIEN2,"LRCPT","ERR")
S LRXX=""
F S LRXX=$O(LRCPT(LRXX)) Q:LRXX="" D
.Q:$P(LRCPT(LRXX),"^",3)'=LRVIS
.S LRCPT2=""
.S LRCPT2=+$G(LRCPT(LRXX))
.D:LRCPT2
..S (LRX1,LRQT)=0
..F S LRX1=$O(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1)) Q:LRX1=""!(LRQT) D
...S LRCPT1=+$G(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"PROCEDURE"))
...I LRCPT1=LRCPT2 D
....S LRQ1=$P(LRCPT(LRXX),"^",16)
....S LRQ2=+$G(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"QTY"))
....S ^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"QTY")=LRQ1+LRQ2
....S LRQT=1
Q
;
CLEAN ;Final Cleanup
K AFTER812,AGE,CPT,D,D0,DOB,DDER,DFN,DI,DIC,DIG,DIH,DIR,DIRUT
K DISL,DIRUT,DIU,DUOUT,DIV,DQ
K I,J,LRACC,LRCNT,LRI,POP,PXALOOK,PXASUB,PXJ,PXJJ
K SDT1,SPEL,SUBL,T1,TYPEI,X,XPARSYS
K ANS,CLN,CNT,FPRI,LRAA,LRAD,LRAN,LRANSX,LRANSY,LRCDT,LRCNT
K LRDFN,LRDPF,LRDLOC,LRDSSID,LRDSSLOC,LRDUZ,LREDT,LREND,LRES,LRESCPT
K LRIDT,LRIDIV,LRLLOC,LRLLOCX,LRLST,LRNINS,LRNLT,LRNLTN,LRNODE0,LRNOP,LROK
K LRPCEN,LRPCENON,LRPCEVSO,LRPKG,LRPRAC,LRPRO,LRRB,LRQ,LRSS,LRTREA,LRTST,LRURG
K LRSPECID,LRTSTP,LRUID,LRVBY
K LRVSITN,LRWRD,LRX,LRXCPT,LRXTST
K NODE,NODE0,PNM,SEX,SDFLAG,SSN,VA,X1,X2,X3
K ^TMP("LRMOD",$J)
K ^TMP("LR",$J,"AK"),^TMP("LR",$J,"LRLST")
K ^TMP("LRPXAPI",$J)
D KVAR^VADPT
K HRCN ; IHS/MSC/MKK - LR*5.2*1031
Q
;
CPT(LRAA,LRAD,LRAN,LRPRO) ;AP Release entry point
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
;LRAA=accession area, LRAD=accession date, LRAN=accession number
;LRPRO=provider
N X,Y,I,LRI,LREDT,LRCDT,LRIDT,LRLLOCX,LRSPECID,DIC,LRNOP,LREND,LRES
S (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
S DIC=44,DIC(0)="ONM",X=LRLLOC D ^DIC
I Y>1 S LRLLOC=+Y
I Y<1 D Q:$G(LREND)
. S DIC(0)="AEZNM" D ^DIC
. I Y<1 S LRNOP="4^Not an outpatient location",LREND=1 Q
. S LRLLOC=+Y
;KLL - set LRDSSLOC to LRDLOC, instead of LRLLOC to resolve location
; problem occurring in PCE
;TAC - use accession area OOS location if one exists
S LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
S LRDSSLOC=$S($G(LRDSSLOC):LRDSSLOC,1:+$G(LRDLOC))
S LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I")
S LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
S LRNINS=$S(LRNINS:LRNINS,1:DUZ(2))
I '$G(LRIDT) S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
S LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
S LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
S:$L($G(LRUID)) LRSPECID=LRSPECID_" UID: "_LRUID
S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
I 'LREDT S LREDT=$$NOW^XLFDT
S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
I '$G(LRESCPT) D Q
. D EN^DDIOL("CPT workload is not activated","","!?20")
I $S('$G(LRAA):1,'$G(LRAD):1,'$G(LRAN):1,'$G(LRPRO):1,1:0) Q
I +$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))'=LRDFN Q
D CPTEN
Q
LRCAPES ;DALOI/FHS/KLL -MANUAL PCE CPT WORKLOAD CAPTURE ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**274,1018,259,1030,349,308,1031,1033**;NOV 1, 1997
+2 ;
+3 ;Reference to $$GET^XUA4A72 - Supported by DBIA #1625
EN ; EP
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 DO EN^LRCAPES1
+4 QUIT
+5 ;
EX1 ;Parse the read entry
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW LRXY,LRACTV,LRXY1,LRXY2,LRD2,LRNR,LRWL2,LRINA2,LRREL2,LRQ
+4 IF '$LENGTH($GET(LRX))
QUIT
+5 ;Edit on 5-digit code entry
+6 IF LRX?5N
IF '$DATA(^TMP("LR",$JOB,"AK",LRX))#2
Begin DoDot:1
+7 SET LRXY=$$CPT^ICPTCOD(LRX,DT)
+8 DO CHKCPT^LRCAPES1
+9 ;Don't pass to PCE if CPT is missing or inactive in #81 or #64
+10 IF '$PIECE(LRXY,U,7)!(LRNR)
QUIT
+11 ;If CPT is inactive in #64 and another active CPT exists, replace
+12 ; the inactive with the active CPT
+13 IF LRACTV
Begin DoDot:2
+14 SET LRXY=$$CPT^ICPTCOD(LRXY2,DT)
+15 SET LRCNT=+$GET(LRCNT)+1
+16 SET ^TMP("LR",$JOB,"LRLST",LRCNT)=$PIECE(LRXY,U)_U_LRWL2_U_$PIECE(LRXY,U,3)_U
+17 SET LRRF64=$SELECT($GET(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
+18 ;If CPT passes edits, continue
End DoDot:2
QUIT
+19 SET LRCNT=+$GET(LRCNT)+1
+20 SET ^TMP("LR",$JOB,"LRLST",LRCNT)=$PIECE(LRXY,U)_"^^"_$PIECE(LRXY,U,3)_U
End DoDot:1
QUIT
+21 ;Edit on ES Display Order # entry
+22 SET LRQ="^TMP(""LR"","_$JOB_",""AK"","_LRX_")"
+23 SET LRQ=$QUERY(@LRQ)
+24 SET LRXY=$$CPT^ICPTCOD($QSUBSCRIPT(LRQ,6),DT)
+25 DO CHKCPT^LRCAPES1
+26 IF '$PIECE(LRXY,U,7)!(LRNR)
QUIT
+27 ;If CPT is inactive in #64 and another active CPT exists, replace
+28 ; the inactive with the active CPT
+29 IF LRACTV
Begin DoDot:1
+30 SET LRXY=$$CPT^ICPTCOD(LRXY2,DT)
+31 SET LRCNT=+$GET(LRCNT)+1
+32 SET ^TMP("LR",$JOB,"LRLST",LRCNT)=$PIECE(LRXY,U)_U_LRWL2_U_$PIECE(LRXY,U,3)_U
+33 SET LRRF64=$SELECT($GET(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
+34 ;I CPT passes edits, continue
End DoDot:1
QUIT
+35 SET LRCNT=+$GET(LRCNT)+1
+36 SET ^TMP("LR",$JOB,"LRLST",LRCNT)=$QSUBSCRIPT(LRQ,6)_U_@LRQ
+37 QUIT
+38 ;
END1 ;
+1 DO END
SET LREND=1
+2 QUIT
+3 ;
END ;
+1 IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+2 IF '$GET(LRESCPT)
KILL ^TMP("LR",$JOB,"AK")
+3 IF $GET(LRDEBUG)
WRITE !,"END ",!
QUIT
+4 QUIT
+5 ;
WLN ;Interactive entry point
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 DO KVA^VADPT
+4 ;
+5 KILL DIC,DIR
+6 KILL LREND,LRUID,DIC,DIR,LRVBY
+7 KILL ^TMP("LR",$JOB,"LRLST")
+8 KILL LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LRIDT
+9 KILL LRRB,LRSS,LRTIME,LRTREA,LRUID,LRWRD,PNM,SEX,SSN,AGE
+10 SET (LRAA,LRACC,LRAD,LRNOP,LRAN,LREND)=0
SET LRVBY=1
SET LRUID=""
+11 IF '$GET(LRPRO)
SET LRPRO=DUZ
+12 IF '$GET(LRESCPT)
SET LRVBY=$$SELBY^LRWU4("Select Accession By")
+13 IF LRVBY=1
DO ^LRVERA
IF LRVBY=2
DO UID^LRVERA
+14 IF 'LRVBY!(LRAA<1)
DO END
SET LREND=1
QUIT
+15 SET LRDFN=+$$GET1^DIQ(68.02,+$GET(LRAN)_","_+$GET(LRAD)_","_+$GET(LRAA)_",",.01)
+16 IF 'LRDFN
DO END
SET LRNOP=1
Begin DoDot:1
+17 WRITE !?5,"This accession is corrupt",!
End DoDot:1
QUIT
+18 ;
LCK ;
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):10
IF '$TEST
Begin DoDot:1
+4 WRITE !?5,"Someone else is editing this accession",!
+5 SET LRNOP=1
End DoDot:1
QUIT
+6 DO PT^LRX
+7 SET LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
+8 SET LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
+9 SET LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
+10 IF $LENGTH($GET(LRUID))
SET LRSPECID=LRSPECID_" UID: "_LRUID
+11 SET LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
+12 IF LREDT'?7N.E
Begin DoDot:1
+13 WRITE !?5,"This accession does not have a Collection Date/Time",!
+14 WRITE !?10,"CAN NOT PROCEED",!
+15 SET LRNOP="6^Not Accessioned"
End DoDot:1
QUIT
+16 IF '$GET(LRIDT)
SET LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
+17 SET LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
+18 IF '$LENGTH($GET(LRSS))
SET LRSS=$$GET1^DIQ(68,LRAA_",",.02,"I")
+19 SET LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
+20 SET LRDSSLOC=$SELECT($GET(LRDSSLOC):LRDSSLOC,1:LRDLOC)
+21 DO DEM^LRCAPES1
+22 ;
PRO ;Get provider,patient/location information
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 SET LREND=0
+4 Begin DoDot:1
+5 NEW LRPRONM,DIR,DIRUT,DUOUT,X,Y
+6 SET LRPRONM=$$GET1^DIQ(200,+$GET(LRPRO),.01,"I")
+7 IF $LENGTH(LRPRONM)
IF $DATA(^VA(200,"AK.PROVIDER",LRPRONM,+$GET(LRPRO)))#2
IF $$GET^XUA4A72(+$GET(LRPRO),DT)>0
SET DIR("B")=LRPRONM
+8 ;S DIR("A")="Releasing Pathologist"
+9 SET DIR("A")="Provider"
+10 SET LRPRO=0
SET DIR(0)="PO^200:ENMZ"
+11 SET DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
+12 DO ^DIR
+13 IF Y>1
SET LRPRO=+Y
End DoDot:1
+14 IF '$GET(LRPRO)
Begin DoDot:1
+15 WRITE !?5,"No Active Provider Selected",!
+16 SET LRNOP=1
End DoDot:1
DO END1
QUIT
+17 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
Begin DoDot:1
+18 WRITE !?5,"The accession is corrupt - missing zero node",!
+19 SET LRNOP="7^Corrupt Accession"
End DoDot:1
DO END1
GOTO WLN
+20 ;
LOC ;Reporting Location
+1 SET LRNODE0=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
+2 SET LRNOP=0
+3 SET (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
+4 IF $LENGTH(LRLLOC)
SET LRLLOC=+$$FIND1^DIC(44,"","OM",LRLLOC)
+5 ;
ASKLOC ;Check to see if outpatient location
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF '$DATA(^SC(+$GET(LRLLOC),0))#2
Begin DoDot:1
+4 NEW DIR,X,Y
+5 SET LRLLOC=""
+6 SET DIR(0)="PO^44:AEZNMO"
SET DIR("A")=" Ordering Location "
+7 DO ^DIR
+8 IF +Y<1
QUIT
+9 SET LRLLOC=+Y
End DoDot:1
+10 IF '$GET(LRLLOC)
DO END1
QUIT
+11 ;I 'LRDSSID S LRNOP="2^No Stop Code Number" Q
SET LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I")
+12 SET LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
+13 SET LRNINS=$SELECT(LRNINS:LRNINS,1:DUZ(2))
+14 QUIT
+15 ;
ES() ; EP - Entry point for front end application.
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW DFN,LRESCPT,LRDFN,LRLLOC,LRLLOCX,LRNINS,LRTST,LRENCDT,LRDUZ
+4 KILL LRES,LRESCPT
+5 SET LRES=1
+6 ;
ASK ; Option entry point - Check and setup PCE reporting variables
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 DO EN^LRCAPES1
+4 NEW X,Y,T1
+5 SET LREND=0
+6 DO ^LRPARAM
IF $GET(LREND)
QUIT
+7 KILL ^TMP("LRPXAPI",$JOB),^TMP("LR",$JOB,"LRLST")
+8 SET ^TMP("LR",$JOB,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
+9 IF '$GET(LRPKG)
SET LRPKG=$ORDER(^DIC(9.4,"B","LR",0))
+10 IF '$GET(LRPKG)
SET LRPKG=$ORDER(^DIC(9.4,"B","LAB SERVICE",0))
+11 ;
PKG ;Check to see if Lab Package is installed
+1 IF '$GET(LRPKG)
Begin DoDot:1
+2 WRITE !?5,"LAB SERVICE PACKAGE is not loaded",!
End DoDot:1
DO WKL
QUIT
+3 ;
PCE ;Check to see if PCE is turned on
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 SET X="PXAI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
IF '$GET(LRES)
Begin DoDot:1
+4 WRITE !?5,"PCE Is not installed",!
End DoDot:1
DO WKL
QUIT
+5 SET LRPCEON=$$PKGON^VSIT("PX")
+6 IF '$GET(LRES)
IF 'LRPCEON
Begin DoDot:1
+7 WRITE !?5,"PCE is not turned on",!
End DoDot:1
DO WKL
QUIT
+8 SET LRDLOC=+$$GET1^DIQ(69.9,"1,",.8,"I")
+9 ;
OOS ;Check to see if the LRDLOC is an OOS location
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF $GET(LRES)
IF $PIECE($GET(^SC(LRDLOC,0)),U)'["LAB DIV "
Begin DoDot:1
+4 WRITE !?5,"DEFAULT LAB OOS LOCATION is not defined correctly",!
End DoDot:1
DO WKL
QUIT
+5 SET LRESCPT=1
+6 IF '$GET(^TMP("LR",$JOB,"AK",0,1))'=DUZ_U_DT
DO EN
+7 IF $GET(LRES)
QUIT $GET(LRESCPT)
+8 ;
LOOP ;
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF $GET(LREND)
QUIT
+4 FOR
DO WLN
IF $GET(LREND)
QUIT
IF '$GET(LRNOP)
DO CPTEN
IF $GET(LREND)
QUIT
+5 DO CLEAN
QUIT
+6 ;
CPTEN ; EP - Entry point from CPT API call
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 ;
WKL ; S (LRNOP,LREND)=0 D READ^LRCAPES1 ; IHS/MSC/MKK - LR*5.2*1033
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 SET (LRNOP,LREND)=0
DO READ^LRCAPES1
+4 ;
+5 DO DIS^LRCAPES1
+6 IF '$ORDER(^TMP("LR",$JOB,"LRLST",0))
DO END
QUIT
+7 ;
LOAD ;Setup ^TMP("LRPXAPI" to load CPT workload
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 KILL LRXCPT,LRXTST,^TMP("LRPXAPI",$JOB)
+4 ;
+5 SET LRDUZ=LRPRO
+6 IF '$GET(LRESCPT)
SET LRNOP="3^PCE Workload Capture Not Setup"
+7 IF $GET(LRNOP)
Begin DoDot:1
+8 IF '$DATA(LRQUIET)
WRITE !,$$CJ^XLFSTR("PCE Wkld Abort "_$PIECE(LRNOP,U,2),IOM)
End DoDot:1
DO SENDWKL
QUIT
+9 IF $GET(LRESCPT)
IF '$GET(LRNOP)
Begin DoDot:1
+10 NEW AFTER812,D,D0,DDER,DI,DIC,DIG,DIH,DISL,DIV
+11 NEW I,LRACC,LRCNT,LRI,LRPCEN,PXALOOK,PXASUB,PXJ,PXJJ,LRCCT
+12 NEW SDT1,SPEL,SUBL,TYPEI,X,XPARSYS
+13 SET LRTST=0
+14 FOR
SET LRTST=$ORDER(^TMP("LR",$JOB,"LRLST",LRTST))
IF LRTST<1
QUIT
Begin DoDot:2
+15 SET (LRNLTN,CPT)=+$GET(^TMP("LR",$JOB,"LRLST",LRTST))
SET LRTSTP=$PIECE(^(LRTST),U,2,99)
+16 DO SET^LRCAPPH1
End DoDot:2
+17 DO ADDPREV
End DoDot:1
+18 ;
SENDWKL ; Store LMIP workload
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 DO SEND^LRCAPES1
+4 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+5 SET LRNOP=0
+6 QUIT
+7 ;
ADDPREV ;Add CPT quantities from PCE to current totals
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW LRSTR2,LRIEN2,LRPX,LRCPT,LRXX,LRCPT2,LRCPT1,LRX1,LRQ1,LRQ2,LRQT,LRCT
+4 SET LRSTR2=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
+5 IF 'LRSTR2
QUIT
+6 KILL LRVIS
SET LRVIS=""
+7 SET LRCT=$LENGTH(LRSTR2,";")-1
SET LRVIS=$PIECE(LRSTR2,";",LRCT)
+8 FOR LRPX=1:1
SET LRIEN2=$PIECE(LRSTR2,";",LRPX)
IF LRIEN2=""
QUIT
Begin DoDot:1
+9 DO GETCPT^PXAPIOE(LRIEN2,"LRCPT","ERR")
End DoDot:1
+10 SET LRXX=""
+11 FOR
SET LRXX=$ORDER(LRCPT(LRXX))
IF LRXX=""
QUIT
Begin DoDot:1
+12 IF $PIECE(LRCPT(LRXX),"^",3)'=LRVIS
QUIT
+13 SET LRCPT2=""
+14 SET LRCPT2=+$GET(LRCPT(LRXX))
+15 IF LRCPT2
Begin DoDot:2
+16 SET (LRX1,LRQT)=0
+17 FOR
SET LRX1=$ORDER(^TMP("LRPXAPI",$JOB,"PROCEDURE",LRX1))
IF LRX1=""!(LRQT)
QUIT
Begin DoDot:3
+18 SET LRCPT1=+$GET(^TMP("LRPXAPI",$JOB,"PROCEDURE",LRX1,"PROCEDURE"))
+19 IF LRCPT1=LRCPT2
Begin DoDot:4
+20 SET LRQ1=$PIECE(LRCPT(LRXX),"^",16)
+21 SET LRQ2=+$GET(^TMP("LRPXAPI",$JOB,"PROCEDURE",LRX1,"QTY"))
+22 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRX1,"QTY")=LRQ1+LRQ2
+23 SET LRQT=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
CLEAN ;Final Cleanup
+1 KILL AFTER812,AGE,CPT,D,D0,DOB,DDER,DFN,DI,DIC,DIG,DIH,DIR,DIRUT
+2 KILL DISL,DIRUT,DIU,DUOUT,DIV,DQ
+3 KILL I,J,LRACC,LRCNT,LRI,POP,PXALOOK,PXASUB,PXJ,PXJJ
+4 KILL SDT1,SPEL,SUBL,T1,TYPEI,X,XPARSYS
+5 KILL ANS,CLN,CNT,FPRI,LRAA,LRAD,LRAN,LRANSX,LRANSY,LRCDT,LRCNT
+6 KILL LRDFN,LRDPF,LRDLOC,LRDSSID,LRDSSLOC,LRDUZ,LREDT,LREND,LRES,LRESCPT
+7 KILL LRIDT,LRIDIV,LRLLOC,LRLLOCX,LRLST,LRNINS,LRNLT,LRNLTN,LRNODE0,LRNOP,LROK
+8 KILL LRPCEN,LRPCENON,LRPCEVSO,LRPKG,LRPRAC,LRPRO,LRRB,LRQ,LRSS,LRTREA,LRTST,LRURG
+9 KILL LRSPECID,LRTSTP,LRUID,LRVBY
+10 KILL LRVSITN,LRWRD,LRX,LRXCPT,LRXTST
+11 KILL NODE,NODE0,PNM,SEX,SDFLAG,SSN,VA,X1,X2,X3
+12 KILL ^TMP("LRMOD",$JOB)
+13 KILL ^TMP("LR",$JOB,"AK"),^TMP("LR",$JOB,"LRLST")
+14 KILL ^TMP("LRPXAPI",$JOB)
+15 DO KVAR^VADPT
+16 ; IHS/MSC/MKK - LR*5.2*1031
KILL HRCN
+17 QUIT
+18 ;
CPT(LRAA,LRAD,LRAN,LRPRO) ;AP Release entry point
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 ;LRAA=accession area, LRAD=accession date, LRAN=accession number
+4 ;LRPRO=provider
+5 NEW X,Y,I,LRI,LREDT,LRCDT,LRIDT,LRLLOCX,LRSPECID,DIC,LRNOP,LREND,LRES
+6 SET (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
+7 SET DIC=44
SET DIC(0)="ONM"
SET X=LRLLOC
DO ^DIC
+8 IF Y>1
SET LRLLOC=+Y
+9 IF Y<1
Begin DoDot:1
+10 SET DIC(0)="AEZNM"
DO ^DIC
+11 IF Y<1
SET LRNOP="4^Not an outpatient location"
SET LREND=1
QUIT
+12 SET LRLLOC=+Y
End DoDot:1
IF $GET(LREND)
QUIT
+13 ;KLL - set LRDSSLOC to LRDLOC, instead of LRLLOC to resolve location
+14 ; problem occurring in PCE
+15 ;TAC - use accession area OOS location if one exists
+16 SET LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
+17 SET LRDSSLOC=$SELECT($GET(LRDSSLOC):LRDSSLOC,1:+$GET(LRDLOC))
+18 SET LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I")
+19 SET LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
+20 SET LRNINS=$SELECT(LRNINS:LRNINS,1:DUZ(2))
+21 IF '$GET(LRIDT)
SET LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
+22 SET LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
+23 SET LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
+24 SET LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
+25 IF $LENGTH($GET(LRUID))
SET LRSPECID=LRSPECID_" UID: "_LRUID
+26 SET LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
+27 IF 'LREDT
SET LREDT=$$NOW^XLFDT
+28 SET LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
+29 IF '$GET(LRESCPT)
Begin DoDot:1
+30 DO EN^DDIOL("CPT workload is not activated","","!?20")
End DoDot:1
QUIT
+31 IF $SELECT('$GET(LRAA):1,'$GET(LRAD):1,'$GET(LRAN):1,'$GET(LRPRO):1,1:0)
QUIT
+32 IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))'=LRDFN
QUIT
+33 DO CPTEN
+34 QUIT
