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