LRCAPES1 ;DALOI/FHS/KLL-CONT MANUAL PCE CPT WORKLOAD CAPTURE ; 22-Oct-2013 09:22 ; MKK
;;5.2;LAB SERVICE;**274,308,1031,1033**;NOV 1, 1997
;
;Continuation of LRCAPES
EN ; EP - Setup the order of defined NLT codes
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
; ^ICPTCOD supported by DBIA 1995-A
Q:$G(^TMP("LR",$J,"AK",0,1))=DUZ_U_DT
N LRI,LRY,LRX,LRX2,LRX3,LRDES,LRCNT
K ^TMP("LR",$J,"AK")
S LRCNT=0
S ^TMP("LR",$J,"AK",0)=$$FMADD^XLFDT(DT,2)_U_DT_U_"ES CPT code list"
S ^TMP("LR",$J,"AK",0,1)=DUZ_U_DT
S LRY="^LAM(""AK"")" F S LRY=$Q(@LRY) Q:$QS(LRY,1)'="AK" D
. N LRDES
. S LRX2=$QS(LRY,2),LRX3=$QS(LRY,3)
. Q:'$G(LRX2)!('$G(LRX3))
. S LRI=0 F S LRI=$O(^LAM(LRX3,4,"AC","CPT",LRI)) Q:LRI<1 D
. . S LRX=+$G(^LAM(LRX3,4,LRI,0)),LRX=$$CPT^ICPTCOD(LRX,DT)
. . Q:'$P(LRX,U,7)
. . K LRDES S LRDES=$$CPTD^ICPTCOD(+LRX,"LRDES")
. . S LRCNT=LRCNT+1
. . I $L(LRDES(1)) S ^TMP("LR",$J,"AK",LRX2,LRI,+LRX)=LRX3_U_$E(LRDES(1),1,55)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E") Q
. . S ^TMP("LR",$J,"AK",LRX2,LRI,+LRX)=LRX3_U_$P(LRX,U,3)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E")
Q
;
SET(DFN,LRPRO,LREDT,LRLOC,LRINS,LRCPT,LRAA,LRAD,LRAN) ; Call to check variable
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
S (LREND,LROK)=0,LRAA=+$G(LRAA),LRAD=+$G(LRAD),LRAN=+$G(LRAN)
I '$D(^DPT(DFN,0))#2 S LROK="1^Error Patient" Q LROK
I $$GET^XUA4A72(LRPRO,DT)<1 S LROK="2^Inactive Provider" Q LROK
I LREDT'?7N.E S LROK="3^Date Format" Q LROK
I '$D(^SC(LRLOC,0))#2 S LROK="4^Location Error" Q LROK
I "CMZ"'[$P($G(^SC(LRLOC,0)),U,3) S LROK="4.2^Not Inpatient Location" Q LROK
I '$G(LRDSSID) S LROK="4.2^Not Inpatient Location" Q LROK
I '$D(^DIC(4,LRINS,0))#2 S LROK="5^Institution Error" Q LROK
I '$O(LRCPT(0)) S LROK="6^No CPT Codes Passed" Q LROK
D EN^LRCAPES,READ^LRCAPES1
D DIS I '$O(^TMP("LR",$J,"LRLST",0)) S LROK="-1" Q LROK
D LOAD^LRCAPES,CLEAN^LRCAPES
Q LROK
;
SEND ;Send data to PCE via DATA2PCE^PXAPI API
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
I $$GET1^DIQ(63,+$G(LRDFN),.02,"I")=2,$G(LRDSSID),$O(^TMP("LRPXAPI",$J,"PROCEDURE",0)) D
. I '$D(LRQUIET) W !,$$CJ^XLFSTR("Sending PCE Workload",IOM)
. S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) ^("PCE")="" S LRPCEN=^("PCE")
. S LREDT=$S($G(LREDT):LREDT,1:$$NOW^XLFDT)
. S:'$P(LREDT,".",2) $P(LREDT,".",2)="1201"
. D SEND^LRCAPPH1
. I '$D(LRQUIET) W $$CJ^XLFSTR("Visit # "_LRVSITN,80)
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")=$E(LRPCEN_LRVSITN_";",1,80)
D SETWKL(LRAA,LRAD,LRAN)
Q
;
SETWKL(LRAA,LRAD,LRAN) ;Set workload into 68 from CPT coding
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+$G(LRAA),0)),U,16))
I '$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)) Q
I '$O(^TMP("LR",$J,"LRLST",0)) K ^TMP("LR",$J,"LRLST") Q
I '$D(LRQUIET) W !,$$CJ^XLFSTR("Storing LMIP Workload",IOM)
N LRCNT,LRT,LRP,LRTIME,LRCDEF,LRURGW,LRI,LRADD
S:'$G(LRURG) LRURG=9
S (LRADD,LRCNT)=1,LRCDEF="3000",LRURGW=+$G(LRURG)
S LRT("P")=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
S LRI=0 F S LRI=$O(^TMP("LR",$J,"LRLST",LRI)) Q:LRI<1 D
. S LRP=$P(^TMP("LR",$J,"LRLST",LRI),U,2)
. I 'LRP D Q:'LRP
. . S LRP=+$O(^LAM("AB",$P(^TMP("LR",$J,"LRLST",LRI),U)_";ICPT(",0))
. Q:'($D(^LAM(LRP,0))#2)
. S LRT=+$O(^LAM(LRP,7,"B",0))
. I 'LRT S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
. Q:'LRT
. D SET^LRCAPV1S,STUFI^LRCAPV1
K ^TMP("LR",$J,"LRLST")
Q
;
DIS ;
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N X9
K X,LRLST,LRCNT,LRI,LRX,LRXY,LRXTST
K ^TMP("LR",$J,"LRLST")
N LRNOTFD,LRNOLK,LRIA81,LRIA64,LRRF64
I $G(LRANSX) D
. S X=LRANSX D RANGE^LRWU2
. X (X9_"S LRX=T1 D EX1^LRCAPES")
I '$O(^TMP("LR",$J,"LRLST",0)) D Q
. W !!!,?5,"The following CPT Code(s) are not selected:"
. W:$G(LRNOTFD) !?8,"Not found in #81: ",LRNOTFD
. W:$G(LRIA81) !?8,"Inactive in #81: ",LRIA81
. W:$G(LRIA64) !?8,"Inactive in #64: ",LRIA64
. W:$G(LRNOLK) !?8,"Not linked to workload: ",LRNOLK
. W !
. S LRANSY=0
D DEM
;
CHK ;User accepts CPT list
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N DIR
S DIR("A")="Is this correct "
S DIR(0)="Y",DIR("B")="Yes" D RD
I $G(LRANSY)'=1 D
.K ^TMP("LR",$J,"LRLST")
.S ^TMP("LR",$J,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
Q
;
PG ;Page break
N DIR,DIRUT,DUOUT,DTOUT
S DIR(0)="E" D ^DIR
I $G(DIRUT) S LREND=1 Q
W @IOF
Q
;
RD ;DIR read
N Y,X,DTOUT,DUOUT,DIRUT,DIROUT
S (LRANSY,LRANSX)=0
S LREND=0 W !
D ^DIR I $D(DIRUT) S LREND=1 Q
S LRANSY=$G(Y),LRANSX=$G(X)
Q
;
READ ;Select CPT codes for accession
; Ask if want to see previously loaded CPT codes
D LSTCPT(LRAA,LRAD,LRAN)
N DIR,LREND
S DIR(0)="LO",LREND=0
S DIR("A")="Select CPT codes"
S DIR("?")="List or range e.g, 1,3,5-7,88000."
S DIR("??")="^D HLP^LRCAPES1"
D RD
Q
;
DEM ;
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N LRIENS,DA
S LRIENS=LRAN_","_LRAD_","_LRAA_","
W @IOF
; W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
W !?3,PNM,?35,HRCN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1) ; IHS/MSC/MKK - LR*5.2*1031
W !?5,LRCDT
W !?10,LRSPECID,?60,"Loc: ",$G(LRLLOCX)
I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
W !?15,"Specimen: ",$$GET1^DIQ(68.05,"1,"_LRIENS,.01,"E")
I $L($G(LRSS)),$O(^LR(LRDFN,LRSS,LRIDT,.1,0)) D
. N LRX
. W !?5,"Tissue Specimens: "
. S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRIDT,.1,LRX)) Q:LRX<1 W !,?15,$P($G(^(LRX,0)),U)
W !?5,"Test(s); "
S (LREND,LRX)=0 D
. N LREND
. F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX)) Q:LRX<1!($G(LREND)) D
. . I $Y>(IOSL-5) D PG Q:$G(LREND)
. . W ?15,$P($G(^LAB(60,+LRX,0)),U)_"/ "
;Display pathologist's name
N LRPATH,LRIENS,LRFL
S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
I LRSS'="AU" D
.S LRFL=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
.S LRIENS=LRIDT_","_LRDFN_","
.S LRPATH=$$GET1^DIQ(LRFL,LRIENS,.02,"I")
S LRPATH=$$GET1^DIQ(200,+$G(LRPATH),.01,"I")
W:LRSS="CY" !?5,"Pathologist/Cytotechnologist: ",LRPATH,!
W:LRSS'="CY" !?5,"Pathologist: ",LRPATH,!
;
Q:'$O(^TMP("LR",$J,"LRLST",0))
W !!,$$CJ^XLFSTR("Selected CPT Codes",IOM)
W ! S (LREND,LRX)=0 D
. N LREND,LRTMP
. S LRTMP=0
. F S LRX=+$O(^TMP("LR",$J,"LRLST",LRX)) Q:LRX<1!($G(LREND)) D
. . I $Y>(IOSL-5) D PG Q:$G(LREND)
. . S LRTMP=$G(^TMP("LR",$J,"LRLST",LRX))
. . W !?5,"("_LRX_") "_$P(LRTMP,U)_" "_$E($P(LRTMP,U,3),1,50),!
. . W:$P(LRTMP,U,5) ?10,$E($P(LRTMP,U,4),1,50)_" {"_$P(LRTMP,U,5)_"}"
I $G(LRNOTFD)!$G(LRIA81)!$G(LRIA64)!$G(LRNOLK)!$G(LRRF64) D
. W !!!?5,"The following CPT Codes are NOT Selected"
. W:$G(LRNOTFD) !?8,"Not found in #81: ",LRNOTFD
. W:$G(LRIA81) !?8,"Inactive in #81: ",LRIA81
. W:$G(LRIA64) !?8,"Inactive in #64: ",LRIA64
. W:$G(LRNOLK) !?8,"Not Linked to Workload: ",LRNOLK
. W:$G(LRRF64) !?8,"Inactive in #64\Active Replacement Found: ",LRRF64
Q
;
CHKCPT ;Edit CPT code - does it exist,active in 81 or 64, linked to workload?
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N LRINACT,LRII
S (LRNR,LRACTV,LRXY2,LRWL2,LRD2)=0,LRXY1=$P(LRXY,U)
I LRXY1=-1 S LRNOTFD=$S($G(LRNOTFD):LRNOTFD_LRX_",",1:LRX_",") Q
I '$P(LRXY,U,7) S LRIA81=$S($G(LRIA81):LRIA81_LRXY1_",",1:LRXY1_",") Q
I '$O(^LAM("AB",LRXY1_";ICPT(",0)) D Q
. S LRNOLK=$S($G(LRNOLK):LRNOLK_LRXY1_",",1:LRXY1_","),LRNR=1
;If CPT is not active in 64, look for alternative active CPT
S LRWL2=+$O(^LAM("AB",LRXY1_";ICPT(",0))
S:$G(LRQ)'="" LRWL2=$P(@LRQ,"^") ;For ES Display CPTs
Q:'LRWL2
S LRD2=+$O(^LAM("AB",LRXY1_";ICPT(",LRWL2,LRD2))
S LRREL2=$P(^LAM(LRWL2,4,LRD2,0),U,3),LRINA2=$P(^(0),U,4)
Q:LRREL2&(LRINA2="")
Q:LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2=""))
;CPT is inactive, search for another linked, active CPT to replace it
S LRD2="A",LRD2=$O(^LAM(LRWL2,4,LRD2),-1)
I LRD2>1 D
.S LRII=0,(LRREL2,LRINA2)=""
.F S LRII=$O(^LAM(LRWL2,4,LRII)) Q:'LRII!(LRACTV) D
..S LRXY2=+$P(^LAM(LRWL2,4,LRII,0),U)
..Q:LRXY2=LRXY1
..S LRREL2=$P(^LAM(LRWL2,4,LRII,0),U,3),LRINA2=$P(^(0),U,4)
..I LRREL2&(LRINA2="") S LRACTV=1 Q
..I LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2="")) S LRACTV=1 Q
;No replacement active CPT found,
I 'LRACTV S LRIA64=$S($G(LRIA64):LRIA64_LRXY1_",",1:LRXY1_","),LRNR=1 Q
Q
;
LSTCPT(LRAA,LRAD,LRAN) ; Show loaded CPT codes if any
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
Q:$S('$G(LRAA):1,'$G(LRAD):1,'$G(LRAN):1,1:0)
;
N LRSTR
S LRSTR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) Q:'LRSTR
N DA,DIC,DIR,DIRUT,DIR,DR,ERR,DUOUT,IEN,LRDA,LRENC,LREND,LRP,S,X,Y
S DIR(0)="Y",DIR("A")=" Would you like to see PCE CPT Information"
S DIR("B")="No" D ^DIR Q:$G(DIRUT)!($G(Y)'=1)
;List filed CPT CODES
W @IOF
F LRP=1:1 S IEN=$P(LRSTR,";",LRP) Q:IEN="" D
. D GETCPT^PXAPIOE(IEN,"LRENC","ERR")
S (LRDA,LREND)=0 F S LRDA=$O(LRENC(LRDA)) Q:'LRDA!($G(LREND)) D
. I $Y>(IOSL-6) D PG W @IOF Q:$G(LREND)
. S S=0,DA=LRDA,DR="0:99",DIC="^AUPNVCPT(" D EN^DIQ
Q
;
HLP ;Help display for CPT selection
Q:$$PATCH^BLRUTIL4("PX*1.0*197")<1 ; IHS/MSC/MKK - LR*5.2*1033
;
N DIR,DIRUT,DUOUT,DTOUT,LREND,LRX,LRY
W @IOF
S LRX="^TMP(""LR"","_$J_",""AK"",0,1)"
W $$CJ^XLFSTR("List or range e.g, 1,3,5-7,88300.",IOM)
W $$CJ^XLFSTR("Select from the following or enter CPT separated by a comma",IOM),!
F S LRX=$Q(@LRX) Q:$QS(LRX,2)'=$J!($G(LREND))!($QS(LRX,1)'="LR") D
. S LRY=@LRX
. W !?3,$QS(LRX,4),?6," = "_$QS(LRX,6)_" "_$E($P(LRY,U,2),1,60),!
. W:$P(LRY,U,4) ?8,$P(LRY,U,3)_" { NLT = "_$P(LRY,U,4)_" }",!
. I $Y>(IOSL-6) S DIR(0)="E" D RD I '$G(LREND) W @IOF
D LSTCPT^LRCAPES1($G(LRAA),$G(LRAD),$G(LRAN))
Q
LRCAPES1 ;DALOI/FHS/KLL-CONT MANUAL PCE CPT WORKLOAD CAPTURE ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**274,308,1031,1033**;NOV 1, 1997
+2 ;
+3 ;Continuation of LRCAPES
EN ; EP - Setup the order of defined NLT codes
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 ; ^ICPTCOD supported by DBIA 1995-A
+4 IF $GET(^TMP("LR",$JOB,"AK",0,1))=DUZ_U_DT
QUIT
+5 NEW LRI,LRY,LRX,LRX2,LRX3,LRDES,LRCNT
+6 KILL ^TMP("LR",$JOB,"AK")
+7 SET LRCNT=0
+8 SET ^TMP("LR",$JOB,"AK",0)=$$FMADD^XLFDT(DT,2)_U_DT_U_"ES CPT code list"
+9 SET ^TMP("LR",$JOB,"AK",0,1)=DUZ_U_DT
+10 SET LRY="^LAM(""AK"")"
FOR
SET LRY=$QUERY(@LRY)
IF $QSUBSCRIPT(LRY,1)'="AK"
QUIT
Begin DoDot:1
+11 NEW LRDES
+12 SET LRX2=$QSUBSCRIPT(LRY,2)
SET LRX3=$QSUBSCRIPT(LRY,3)
+13 IF '$GET(LRX2)!('$GET(LRX3))
QUIT
+14 SET LRI=0
FOR
SET LRI=$ORDER(^LAM(LRX3,4,"AC","CPT",LRI))
IF LRI<1
QUIT
Begin DoDot:2
+15 SET LRX=+$GET(^LAM(LRX3,4,LRI,0))
SET LRX=$$CPT^ICPTCOD(LRX,DT)
+16 IF '$PIECE(LRX,U,7)
QUIT
+17 KILL LRDES
SET LRDES=$$CPTD^ICPTCOD(+LRX,"LRDES")
+18 SET LRCNT=LRCNT+1
+19 IF $LENGTH(LRDES(1))
SET ^TMP("LR",$JOB,"AK",LRX2,LRI,+LRX)=LRX3_U_$EXTRACT(LRDES(1),1,55)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E")
QUIT
+20 SET ^TMP("LR",$JOB,"AK",LRX2,LRI,+LRX)=LRX3_U_$PIECE(LRX,U,3)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
SET(DFN,LRPRO,LREDT,LRLOC,LRINS,LRCPT,LRAA,LRAD,LRAN) ; Call to check variable
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 SET (LREND,LROK)=0
SET LRAA=+$GET(LRAA)
SET LRAD=+$GET(LRAD)
SET LRAN=+$GET(LRAN)
+4 IF '$DATA(^DPT(DFN,0))#2
SET LROK="1^Error Patient"
QUIT LROK
+5 IF $$GET^XUA4A72(LRPRO,DT)<1
SET LROK="2^Inactive Provider"
QUIT LROK
+6 IF LREDT'?7N.E
SET LROK="3^Date Format"
QUIT LROK
+7 IF '$DATA(^SC(LRLOC,0))#2
SET LROK="4^Location Error"
QUIT LROK
+8 IF "CMZ"'[$PIECE($GET(^SC(LRLOC,0)),U,3)
SET LROK="4.2^Not Inpatient Location"
QUIT LROK
+9 IF '$GET(LRDSSID)
SET LROK="4.2^Not Inpatient Location"
QUIT LROK
+10 IF '$DATA(^DIC(4,LRINS,0))#2
SET LROK="5^Institution Error"
QUIT LROK
+11 IF '$ORDER(LRCPT(0))
SET LROK="6^No CPT Codes Passed"
QUIT LROK
+12 DO EN^LRCAPES
DO READ^LRCAPES1
+13 DO DIS
IF '$ORDER(^TMP("LR",$JOB,"LRLST",0))
SET LROK="-1"
QUIT LROK
+14 DO LOAD^LRCAPES
DO CLEAN^LRCAPES
+15 QUIT LROK
+16 ;
SEND ;Send data to PCE via DATA2PCE^PXAPI API
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF $$GET1^DIQ(63,+$GET(LRDFN),.02,"I")=2
IF $GET(LRDSSID)
IF $ORDER(^TMP("LRPXAPI",$JOB,"PROCEDURE",0))
Begin DoDot:1
+4 IF '$DATA(LRQUIET)
WRITE !,$$CJ^XLFSTR("Sending PCE Workload",IOM)
+5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
SET ^("PCE")=""
SET LRPCEN=^("PCE")
+6 SET LREDT=$SELECT($GET(LREDT):LREDT,1:$$NOW^XLFDT)
+7 IF '$PIECE(LREDT,".",2)
SET $PIECE(LREDT,".",2)="1201"
+8 DO SEND^LRCAPPH1
+9 IF '$DATA(LRQUIET)
WRITE $$CJ^XLFSTR("Visit # "_LRVSITN,80)
+10 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")=$EXTRACT(LRPCEN_LRVSITN_";",1,80)
End DoDot:1
+11 DO SETWKL(LRAA,LRAD,LRAN)
+12 QUIT
+13 ;
SETWKL(LRAA,LRAD,LRAN) ;Set workload into 68 from CPT coding
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U,16))
QUIT
+4 IF '$GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0))
QUIT
+5 IF '$ORDER(^TMP("LR",$JOB,"LRLST",0))
KILL ^TMP("LR",$JOB,"LRLST")
QUIT
+6 IF '$DATA(LRQUIET)
WRITE !,$$CJ^XLFSTR("Storing LMIP Workload",IOM)
+7 NEW LRCNT,LRT,LRP,LRTIME,LRCDEF,LRURGW,LRI,LRADD
+8 IF '$GET(LRURG)
SET LRURG=9
+9 SET (LRADD,LRCNT)=1
SET LRCDEF="3000"
SET LRURGW=+$GET(LRURG)
+10 SET LRT("P")=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+11 SET LRI=0
FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"LRLST",LRI))
IF LRI<1
QUIT
Begin DoDot:1
+12 SET LRP=$PIECE(^TMP("LR",$JOB,"LRLST",LRI),U,2)
+13 IF 'LRP
Begin DoDot:2
+14 SET LRP=+$ORDER(^LAM("AB",$PIECE(^TMP("LR",$JOB,"LRLST",LRI),U)_";ICPT(",0))
End DoDot:2
IF 'LRP
QUIT
+15 IF '($DATA(^LAM(LRP,0))#2)
QUIT
+16 SET LRT=+$ORDER(^LAM(LRP,7,"B",0))
+17 IF 'LRT
SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+18 IF 'LRT
QUIT
+19 DO SET^LRCAPV1S
DO STUFI^LRCAPV1
End DoDot:1
+20 KILL ^TMP("LR",$JOB,"LRLST")
+21 QUIT
+22 ;
DIS ;
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW X9
+4 KILL X,LRLST,LRCNT,LRI,LRX,LRXY,LRXTST
+5 KILL ^TMP("LR",$JOB,"LRLST")
+6 NEW LRNOTFD,LRNOLK,LRIA81,LRIA64,LRRF64
+7 IF $GET(LRANSX)
Begin DoDot:1
+8 SET X=LRANSX
DO RANGE^LRWU2
+9 XECUTE (X9_"S LRX=T1 D EX1^LRCAPES")
End DoDot:1
+10 IF '$ORDER(^TMP("LR",$JOB,"LRLST",0))
Begin DoDot:1
+11 WRITE !!!,?5,"The following CPT Code(s) are not selected:"
+12 IF $GET(LRNOTFD)
WRITE !?8,"Not found in #81: ",LRNOTFD
+13 IF $GET(LRIA81)
WRITE !?8,"Inactive in #81: ",LRIA81
+14 IF $GET(LRIA64)
WRITE !?8,"Inactive in #64: ",LRIA64
+15 IF $GET(LRNOLK)
WRITE !?8,"Not linked to workload: ",LRNOLK
+16 WRITE !
+17 SET LRANSY=0
End DoDot:1
QUIT
+18 DO DEM
+19 ;
CHK ;User accepts CPT list
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW DIR
+4 SET DIR("A")="Is this correct "
+5 SET DIR(0)="Y"
SET DIR("B")="Yes"
DO RD
+6 IF $GET(LRANSY)'=1
Begin DoDot:1
+7 KILL ^TMP("LR",$JOB,"LRLST")
+8 SET ^TMP("LR",$JOB,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
End DoDot:1
+9 QUIT
+10 ;
PG ;Page break
+1 NEW DIR,DIRUT,DUOUT,DTOUT
+2 SET DIR(0)="E"
DO ^DIR
+3 IF $GET(DIRUT)
SET LREND=1
QUIT
+4 WRITE @IOF
+5 QUIT
+6 ;
RD ;DIR read
+1 NEW Y,X,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET (LRANSY,LRANSX)=0
+3 SET LREND=0
WRITE !
+4 DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
QUIT
+5 SET LRANSY=$GET(Y)
SET LRANSX=$GET(X)
+6 QUIT
+7 ;
READ ;Select CPT codes for accession
+1 ; Ask if want to see previously loaded CPT codes
+2 DO LSTCPT(LRAA,LRAD,LRAN)
+3 NEW DIR,LREND
+4 SET DIR(0)="LO"
SET LREND=0
+5 SET DIR("A")="Select CPT codes"
+6 SET DIR("?")="List or range e.g, 1,3,5-7,88000."
+7 SET DIR("??")="^D HLP^LRCAPES1"
+8 DO RD
+9 QUIT
+10 ;
DEM ;
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW LRIENS,DA
+4 SET LRIENS=LRAN_","_LRAD_","_LRAA_","
+5 WRITE @IOF
+6 ; W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
+7 ; IHS/MSC/MKK - LR*5.2*1031
WRITE !?3,PNM,?35,HRCN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
+8 WRITE !?5,LRCDT
+9 WRITE !?10,LRSPECID,?60,"Loc: ",$GET(LRLLOCX)
+10 IF $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
WRITE !?15,"PCE ENC # "_^("PCE")
+11 WRITE !?15,"Specimen: ",$$GET1^DIQ(68.05,"1,"_LRIENS,.01,"E")
+12 IF $LENGTH($GET(LRSS))
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,.1,0))
Begin DoDot:1
+13 NEW LRX
+14 WRITE !?5,"Tissue Specimens: "
+15 SET LRX=0
FOR
SET LRX=$ORDER(^LR(LRDFN,LRSS,LRIDT,.1,LRX))
IF LRX<1
QUIT
WRITE !,?15,$PIECE($GET(^(LRX,0)),U)
End DoDot:1
+16 WRITE !?5,"Test(s); "
+17 SET (LREND,LRX)=0
Begin DoDot:1
+18 NEW LREND
+19 FOR
SET LRX=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX))
IF LRX<1!($GET(LREND))
QUIT
Begin DoDot:2
+20 IF $Y>(IOSL-5)
DO PG
IF $GET(LREND)
QUIT
+21 WRITE ?15,$PIECE($GET(^LAB(60,+LRX,0)),U)_"/ "
End DoDot:2
End DoDot:1
+22 ;Display pathologist's name
+23 NEW LRPATH,LRIENS,LRFL
+24 IF LRSS="AU"
SET LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
+25 IF LRSS'="AU"
Begin DoDot:1
+26 SET LRFL=$SELECT(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
+27 SET LRIENS=LRIDT_","_LRDFN_","
+28 SET LRPATH=$$GET1^DIQ(LRFL,LRIENS,.02,"I")
End DoDot:1
+29 SET LRPATH=$$GET1^DIQ(200,+$GET(LRPATH),.01,"I")
+30 IF LRSS="CY"
WRITE !?5,"Pathologist/Cytotechnologist: ",LRPATH,!
+31 IF LRSS'="CY"
WRITE !?5,"Pathologist: ",LRPATH,!
+32 ;
+33 IF '$ORDER(^TMP("LR",$JOB,"LRLST",0))
QUIT
+34 WRITE !!,$$CJ^XLFSTR("Selected CPT Codes",IOM)
+35 WRITE !
SET (LREND,LRX)=0
Begin DoDot:1
+36 NEW LREND,LRTMP
+37 SET LRTMP=0
+38 FOR
SET LRX=+$ORDER(^TMP("LR",$JOB,"LRLST",LRX))
IF LRX<1!($GET(LREND))
QUIT
Begin DoDot:2
+39 IF $Y>(IOSL-5)
DO PG
IF $GET(LREND)
QUIT
+40 SET LRTMP=$GET(^TMP("LR",$JOB,"LRLST",LRX))
+41 WRITE !?5,"("_LRX_") "_$PIECE(LRTMP,U)_" "_$EXTRACT($PIECE(LRTMP,U,3),1,50),!
+42 IF $PIECE(LRTMP,U,5)
WRITE ?10,$EXTRACT($PIECE(LRTMP,U,4),1,50)_" {"_$PIECE(LRTMP,U,5)_"}"
End DoDot:2
End DoDot:1
+43 IF $GET(LRNOTFD)!$GET(LRIA81)!$GET(LRIA64)!$GET(LRNOLK)!$GET(LRRF64)
Begin DoDot:1
+44 WRITE !!!?5,"The following CPT Codes are NOT Selected"
+45 IF $GET(LRNOTFD)
WRITE !?8,"Not found in #81: ",LRNOTFD
+46 IF $GET(LRIA81)
WRITE !?8,"Inactive in #81: ",LRIA81
+47 IF $GET(LRIA64)
WRITE !?8,"Inactive in #64: ",LRIA64
+48 IF $GET(LRNOLK)
WRITE !?8,"Not Linked to Workload: ",LRNOLK
+49 IF $GET(LRRF64)
WRITE !?8,"Inactive in #64\Active Replacement Found: ",LRRF64
End DoDot:1
+50 QUIT
+51 ;
CHKCPT ;Edit CPT code - does it exist,active in 81 or 64, linked to workload?
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW LRINACT,LRII
+4 SET (LRNR,LRACTV,LRXY2,LRWL2,LRD2)=0
SET LRXY1=$PIECE(LRXY,U)
+5 IF LRXY1=-1
SET LRNOTFD=$SELECT($GET(LRNOTFD):LRNOTFD_LRX_",",1:LRX_",")
QUIT
+6 IF '$PIECE(LRXY,U,7)
SET LRIA81=$SELECT($GET(LRIA81):LRIA81_LRXY1_",",1:LRXY1_",")
QUIT
+7 IF '$ORDER(^LAM("AB",LRXY1_";ICPT(",0))
Begin DoDot:1
+8 SET LRNOLK=$SELECT($GET(LRNOLK):LRNOLK_LRXY1_",",1:LRXY1_",")
SET LRNR=1
End DoDot:1
QUIT
+9 ;If CPT is not active in 64, look for alternative active CPT
+10 SET LRWL2=+$ORDER(^LAM("AB",LRXY1_";ICPT(",0))
+11 ;For ES Display CPTs
IF $GET(LRQ)'=""
SET LRWL2=$PIECE(@LRQ,"^")
+12 IF 'LRWL2
QUIT
+13 SET LRD2=+$ORDER(^LAM("AB",LRXY1_";ICPT(",LRWL2,LRD2))
+14 SET LRREL2=$PIECE(^LAM(LRWL2,4,LRD2,0),U,3)
SET LRINA2=$PIECE(^(0),U,4)
+15 IF LRREL2&(LRINA2="")
QUIT
+16 IF LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2=""))
QUIT
+17 ;CPT is inactive, search for another linked, active CPT to replace it
+18 SET LRD2="A"
SET LRD2=$ORDER(^LAM(LRWL2,4,LRD2),-1)
+19 IF LRD2>1
Begin DoDot:1
+20 SET LRII=0
SET (LRREL2,LRINA2)=""
+21 FOR
SET LRII=$ORDER(^LAM(LRWL2,4,LRII))
IF 'LRII!(LRACTV)
QUIT
Begin DoDot:2
+22 SET LRXY2=+$PIECE(^LAM(LRWL2,4,LRII,0),U)
+23 IF LRXY2=LRXY1
QUIT
+24 SET LRREL2=$PIECE(^LAM(LRWL2,4,LRII,0),U,3)
SET LRINA2=$PIECE(^(0),U,4)
+25 IF LRREL2&(LRINA2="")
SET LRACTV=1
QUIT
+26 IF LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2=""))
SET LRACTV=1
QUIT
End DoDot:2
End DoDot:1
+27 ;No replacement active CPT found,
+28 IF 'LRACTV
SET LRIA64=$SELECT($GET(LRIA64):LRIA64_LRXY1_",",1:LRXY1_",")
SET LRNR=1
QUIT
+29 QUIT
+30 ;
LSTCPT(LRAA,LRAD,LRAN) ; Show loaded CPT codes if any
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 IF $SELECT('$GET(LRAA)
QUIT
+4 ;
+5 NEW LRSTR
+6 SET LRSTR=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
IF 'LRSTR
QUIT
+7 NEW DA,DIC,DIR,DIRUT,DIR,DR,ERR,DUOUT,IEN,LRDA,LRENC,LREND,LRP,S,X,Y
+8 SET DIR(0)="Y"
SET DIR("A")=" Would you like to see PCE CPT Information"
+9 SET DIR("B")="No"
DO ^DIR
IF $GET(DIRUT)!($GET(Y)'=1)
QUIT
+10 ;List filed CPT CODES
+11 WRITE @IOF
+12 FOR LRP=1:1
SET IEN=$PIECE(LRSTR,";",LRP)
IF IEN=""
QUIT
Begin DoDot:1
+13 DO GETCPT^PXAPIOE(IEN,"LRENC","ERR")
End DoDot:1
+14 SET (LRDA,LREND)=0
FOR
SET LRDA=$ORDER(LRENC(LRDA))
IF 'LRDA!($GET(LREND))
QUIT
Begin DoDot:1
+15 IF $Y>(IOSL-6)
DO PG
WRITE @IOF
IF $GET(LREND)
QUIT
+16 SET S=0
SET DA=LRDA
SET DR="0:99"
SET DIC="^AUPNVCPT("
DO EN^DIQ
End DoDot:1
+17 QUIT
+18 ;
HLP ;Help display for CPT selection
+1 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")<1
QUIT
+2 ;
+3 NEW DIR,DIRUT,DUOUT,DTOUT,LREND,LRX,LRY
+4 WRITE @IOF
+5 SET LRX="^TMP(""LR"","_$JOB_",""AK"",0,1)"
+6 WRITE $$CJ^XLFSTR("List or range e.g, 1,3,5-7,88300.",IOM)
+7 WRITE $$CJ^XLFSTR("Select from the following or enter CPT separated by a comma",IOM),!
+8 FOR
SET LRX=$QUERY(@LRX)
IF $QSUBSCRIPT(LRX,2)'=$JOB!($GET(LREND))!($QSUBSCRIPT(LRX,1)'="LR")
QUIT
Begin DoDot:1
+9 SET LRY=@LRX
+10 WRITE !?3,$QSUBSCRIPT(LRX,4),?6," = "_$QSUBSCRIPT(LRX,6)_" "_$EXTRACT($PIECE(LRY,U,2),1,60),!
+11 IF $PIECE(LRY,U,4)
WRITE ?8,$PIECE(LRY,U,3)_" { NLT = "_$PIECE(LRY,U,4)_" }",!
+12 IF $Y>(IOSL-6)
SET DIR(0)="E"
DO RD
IF '$GET(LREND)
WRITE @IOF
End DoDot:1
+13 DO LSTCPT^LRCAPES1($GET(LRAA),$GET(LRAD),$GET(LRAN))
+14 QUIT
