Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRCAPES

LRCAPES.m

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