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