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

LRCAPPH3.m

Go to the documentation of this file.
  1. LRCAPPH3 ;DALOI/FHS/PC - CHECK CPT CODE AND FILE POINTERS ;Apr 20,2018@12:12pm
  1. ;;5.2;LAB SERVICE;**263,291,505,527**;Sep 27, 1994;Build 16
  1. ;Called from LRCAPPH,LRCAPPH4
  1. EN ;
  1. K ^TMP("LRCAPPH",$J),LRSEP S LRSEP(1)="==================="
  1. S LRSEP(2)="****************"
  1. K %DT S %DT="",X="T+5" D ^%DT S LRPGDT=Y
  1. S ^TMP("LRCAPPH",$J,0)=Y_U_$$NOW^XLFDT_U_"LAB CPT DATA CHECKER"
  1. S ^TMP("LRCAPPH60",$J,0)=Y_U_$$NOW^XLFDT_U_"LAB 60 CPT DATA CHECKER"
  1. K %DT S %DT="" S X="T-1" D ^%DT S LRINADT=$$FMTE^XLFDT(Y,1)
  1. S LRINADTX=Y K %DT
  1. AA ;Look for CPT processing errors
  1. D
  1. . N LRAAN,LRCE,LRTXT,LRX,LR69ORD
  1. . S LRAAN="^LRO(69,""AA"")"
  1. . F S LRAAN=$Q(@LRAAN) Q:$QS(LRAAN,2)'="AA" D
  1. . . S LRX=@LRAAN Q:'LRX S LRCE=$QS(LRAAN,3)
  1. . . ;LR*5.2*527 check if order has been purged and left orphan "AA" entry
  1. . . S LR69ORD=$QS(LRAAN,4)
  1. . . I '$D(^LRO(69,+$P(LR69ORD,"|"),1,+$P(LR69ORD,"|",2),0)) Q
  1. . . K LRTXT
  1. . . S LRTXT="Lab Order Number "_LRCE_" "
  1. . . I LRX<1 D
  1. . . . S LRTXT(1)=LRTXT_" was rejected by the PCE API "
  1. . . I LRX=2 D
  1. . . . S LRTXT(1)=LRTXT_"has no Institution for the ordering location."
  1. . . I LRX=3 D
  1. . . . S LRTXT(1)=LRTXT_"Provider is InActive."
  1. . . I LRX=4 D
  1. . . . S LRTXT(1)=LRTXT_"Not Processed "
  1. . . . S LRTXT(2)=" - No DEFAULT LAB OOS LOCATION defined."
  1. . . I LRX=5 D
  1. . . . S LRTXT(1)=LRTXT_"Ordering Location "
  1. . . . S LRTXT(2)=" has no STOP CODE NUMBER defined."
  1. . . I $D(LRTXT(1)) S LRTXT(10)=LRSEP(1) D MSGSET("LRCAPPH",.LRTXT)
  1. LAM ;Look for inactive Codes and broken pointers.
  1. ;in ^LAM
  1. N LRI,LRXDT,LRY,LRII
  1. S LRI=0 F S LRI=$O(^LAM(LRI)) Q:LRI<1 D I '$D(ZTQUEUED) W:'(LRI#50) "."
  1. . I '$G(LRACT) Q:'$O(^LAM(LRI,7,0))
  1. . S LRII=0 F S LRII=$O(^LAM(LRI,4,LRII)) Q:LRII<1 D
  1. . . I '$G(^LAM(LRI,4,LRII,0)) W:'$D(ZTQUEUED) !,"@@@@@@@@@@@",LRI,! D Q
  1. . . . I '$L($P($G(^LAM(LRI,4,LRII,0)),U)) K ^LAM(LRI,4,LRII) Q
  1. . . . N DR,DA,DIE,DIK
  1. . . . S DA=LRII,DA(1)=LRI,DIK="^LAM("_LRI_",4," D ^DIK
  1. . . K LRX S LRX=^LAM(LRI,4,LRII,0) D CK
  1. LAB ;Look for inactive Codes in ^LAB
  1. N LRJ,LRN,LRSPEC,LRBECPT,MSGTYPE,MSGFLAG,DEFAULT,HCPCS,Y
  1. S LRJ=0 F S LRJ=$O(^LAB(60,LRJ)) Q:'LRJ D
  1. . ;
  1. . ;LR*5.2*505 KAM Added the following to capure data and email to
  1. . ;CLIN 2 to assist in diagnosing an UNDEF issue
  1. . ;
  1. . I '$D(^LAB(60,LRJ,0)) D Q
  1. .. N XMSUB,XMY,XMTEST,XMDUZ,EDITUSER
  1. .. ;LR*5.2*527 - allow for null value of EDITUSER
  1. .. S EDITUSER="UNKNOWN"
  1. .. I $D(^LAB(60,LRJ,15,1,0)) D
  1. ... S EDITUSER=$P($G(^LAB(60,LRJ,15,1,0)),"^",2)
  1. ... I EDITUSER]"" S EDITUSER=$P($G(^VA(200,EDITUSER,0)),"^",1)
  1. ... I EDITUSER="" S EDITUSER="UNKNOWN"
  1. .. S XMSUB="Lab Test IN FILE 60 is missing data "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
  1. .. S XMY(DUZ)=""
  1. .. S XMY("G.HPS T3 Clinical DEV@DOMAIN.EXT")=""
  1. .. S XMDUZ=.5
  1. .. S ^TMP($J,"LABERR",1)="Lab Test "_LRJ_" Does Not Have a Zero Node"
  1. .. S ^TMP($J,"LABERR",2)="and Will Cause an UNDEF Error"
  1. .. S ^TMP($J,"LABERR",3)="Record Skipped and Needs Attention"
  1. .. S ^TMP($J,"LABERR",4)="Test edited by - "_EDITUSER
  1. .. S ^TMP($J,"LABERR",5)="Site Generating the email is "_$P($$SITE^VASITE,"^",2)
  1. .. S ^TMP($J,"LABERR",6)=" "
  1. .. S ^TMP($J,"LABERR",7)="Notes for HPS T3 Clinical DEV:"
  1. .. S ^TMP($J,"LABERR",8)=" "
  1. .. S ^TMP($J,"LABERR",9)="This email pertains to an attempt to determine"
  1. .. S ^TMP($J,"LABERR",10)="the cause of missing data in FILE 60."
  1. .. S ^TMP($J,"LABERR",11)="RTC Ticket Numbers 717838 and 717839"
  1. .. S ^TMP($J,"LABERR",12)="CA/SDM Tickets R18921259FY18 and I19185899FY18"
  1. .. S XMTEXT="^TMP($J,""LABERR"","
  1. .. D ^XMD
  1. .. K ^TMP($J,"LABERR")
  1. . ; End of Coding changes for LR*5.2*505
  1. . ;
  1. . S MSGFLAG=0
  1. . S X=^LAB(60,LRJ,0),LRN=$P(X,U,1)
  1. . I ($P(X,U,4)'="CH")&($P(X,U,4)'="MI") Q
  1. . S LRSPEC=0 F S LRSPEC=$O(^LAB(60,LRJ,1,LRSPEC)) Q:'LRSPEC D
  1. . . K LRBECPT
  1. . . D IACPT(LRJ,DT,LRSPEC)
  1. . . Q:('$D(LRBECPT(LRJ)))
  1. . . S X=$O(LRBECPT(LRJ,1,0)) Q:'X
  1. . . S MSGTYPE="SPECIMEN ("_LRSPEC_") CPT"
  1. . . D MSG2(MSGTYPE)
  1. . S X=$G(^LAB(60,LRJ,1.1)) S DEFAULT=$P(X,U,1),HCPCS=$P(X,U,2)
  1. . I HCPCS D
  1. . . S MSGTYPE="HCPCS CPT"
  1. . . S X=HCPCS,Y=$$CPT^ICPTCOD(X,,,) I '$P(Y,U,7) S X=$P(Y,U,2) D MSG2(MSGTYPE)
  1. . I DEFAULT D
  1. . . S MSGTYPE="DEFAULT CPT"
  1. . . S X=DEFAULT,Y=$$CPT^ICPTCOD(X,,,) I '$P(Y,U,7) S X=$P(Y,U,2) D MSG2(MSGTYPE)
  1. . I MSGFLAG D MSGSET("LRCAPPH60",.LRMSG)
  1. Q
  1. ;
  1. IACPT(LRBETST,LRBECDT,LRSPEC) ; Get inactive specimen CPT
  1. N A,ARR,LRBEAX,LRBEIEN,LRBEAR60,X
  1. S LRBEIEN=LRSPEC_","_LRBETST_",",(LRI,LRBECPT)=""
  1. D GETS^DIQ(60.01,LRBEIEN,"96*","I","LRBEAR60")
  1. S A="" F S A=$O(LRBEAR60(60.196,A)) Q:A="" D
  1. . Q:$G(LRBEAR60(60.196,A,1,"I"))=""
  1. . S ARR($G(LRBEAR60(60.196,A,1,"I")))=$G(LRBEAR60(60.196,A,.01,"I"))
  1. S X=$O(ARR(LRBECDT),-1) I X D
  1. .S LRBEAX=ARR(X)
  1. .S LRBEAX=$$CPT^ICPTCOD(LRBEAX,LRBECDT)
  1. .I '$P(LRBEAX,U,7) S LRBECPT(LRBETST,1,$P(LRBEAX,U,2))="SPECIMEN CPT"
  1. Q
  1. ;
  1. EN0 ;Entry point for scan 64, scan 60, and mail reports to G.LMI
  1. ;Called from LRCAPPH
  1. D EN
  1. D MAIL
  1. D MAIL2
  1. END ;Called from LRCAPPH4
  1. I $E($G(IOST),1,2)="P-" W @IOF
  1. K DA,DIC,DIE,DIK,DR,I
  1. K LRACT,LRCMT,LRINADT,LRINADTX,LRI,LRII,LRMSG,LRN,LRPGDT,LRTST,LRSEP,LRX
  1. K LRTXT,X,XMTEXT,XMSUB,Y
  1. K ^TMP("LRCAPPH",$J),^TMP("LRCAPPH60",$J)
  1. D ^%ZISC
  1. Q
  1. ACTIVE ;Print only WKLD CODES that have associated test assigned
  1. ;and do not have inactivation dates
  1. S LRACT=1 D EN0
  1. Q
  1. CK ;
  1. I '$G(LRACT) Q:$P(LRX,U,4)
  1. K X,Y,DIC,LRMSG
  1. F I=1:1:5 S LRX(I)=$P(LRX,U,I)
  1. I LRX(2)="CPT" D Q
  1. . S X=$P(LRX(1),";")
  1. . S Y=$$CPT^ICPTCOD(X,,,) I $S('$P(Y,U,7):1,LRX(4):1,1:0) D
  1. . . S ^TMP("LRCAPPH",$J,"ICPT",X)=""
  1. . . S Y(0)=$P(Y,U,2,3)_"^^1"
  1. . . D MSG
  1. S DIC(0)="XOZ",X=+LRX(1),DIC=U_$P(LRX(1),";",2)
  1. S:$E(LRX(2))="L" DIC("S")="I '$P($G(^(4)),U)"
  1. D ^DIC
  1. I Y<1 D MSG Q
  1. I $G(LRX(4)) D MSG
  1. Q
  1. MSG ;
  1. K LRMSG
  1. S LRN=^LAM(LRI,0)
  1. S LRCMT=$P($G(^TMP("LRCAPPH",$J,0)),U,4)+1
  1. S LRMSG(LRCMT)=$P(LRN,U,2)_" ["_LRI_"] "_$P(LRN,U),LRCMT=LRCMT+1
  1. I Y<1 D Q
  1. . S LRMSG(LRCMT)="*** Has an invalid "_LRX(2)_" code of "_+X_" ."
  1. . D TST
  1. . I '$P(^LAM(LRI,4,LRII,0),U,4) S $P(^(0),U,4)=LRINADTX D
  1. . . S LRCMT=LRCMT+1,LRMSG(LRCMT)="Inactivation date of "_LRINADT_" has been entered."
  1. . S LRCMT=LRCMT+1,LRMSG(LRCMT)=LRSEP(1)
  1. . D MSGSET("LRCAPPH",.LRMSG)
  1. I $P($G(Y(0)),U,4) D
  1. . N LRXDT
  1. . S LRCMT=LRCMT+1,LRMSG(LRCMT)=$P(Y(0),U)_" "_$P(Y(0),U,2),LRCMT=LRCMT+1
  1. . S LRMSG(LRCMT)="Is an inactive "_LRX(2)_" code."
  1. . D TST
  1. . S:'$P(^LAM(LRI,4,LRII,0),U,4) $P(^(0),U,4)=LRINADTX
  1. . S LRXDT=$P(^LAM(LRI,4,LRII,0),U,4)
  1. . S LRCMT=LRCMT+1,LRMSG(LRCMT)="Inactivation date of "_$$FMTE^XLFDT(LRXDT,1)_" has been entered."
  1. . S LRCMT=LRCMT+1,LRMSG(LRCMT)=LRSEP(2)
  1. . D MSGSET("LRCAPPH",.LRMSG)
  1. Q
  1. MAIL ;Send message to G.LMI local mail group
  1. Q:'$O(^TMP("LRCAPPH",$J,0))
  1. N DUZ,XMDUZ,XMSUB,XMTEXT
  1. S LRCMT=$G(LRCMT)+1
  1. S ^TMP("LRCAPPH",$J,LRCMT,0)="Listing of all offending codes:"
  1. S LRCMT=$G(LRCMT)+1,^TMP("LRCAPPH",$J,LRCMT,0)=""
  1. S LRC="^TMP(""LRCAPPH"",$J,""A"")" F S LRC=$Q(@LRC) Q:$QS(LRC,2)'=$J D
  1. . S LRCMT=LRCMT+1,^TMP("LRCAPPH",$J,LRCMT,0)=" "_$QS(LRC,3)_" "_$QS(LRC,4)
  1. S XMSUB=" NIGHTLY WKLD CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
  1. S XMY("G.LMI")="",XMTEXT="^TMP(""LRCAPPH"","_$J_","
  1. D ^XMD
  1. Q
  1. TST ;
  1. Q:'$O(^LAM(LRI,7,0))
  1. K LRT N X
  1. S LRCMT=$G(LRCMT)+1 S LRMSG(LRCMT)="Associated Tests"
  1. S LRT=0 F S LRT=$O(^LAM(LRI,7,LRT)) Q:LRT<1 S LRTST=$G(^(LRT,0)) D
  1. . S X=+LRTST
  1. . S LRTST="^"_$P(LRTST,";",2)_$P(LRTST,";")_",0)",LRCMT=LRCMT+1
  1. . S LRMSG(LRCMT)=" "_$P(@LRTST,U)_" {"_X_"}"
  1. Q
  1. MSGSET(SUB,TXT) ;SUB=subscript - TXT = array containing the message
  1. N I ;
  1. S LRCMT=$P($G(^TMP(SUB,$J,0)),U,4)
  1. S I=0 F S I=$O(TXT(I)) Q:I<1 D
  1. . S LRCMT=LRCMT+1,^TMP(SUB,$J,LRCMT,0)=TXT(I)
  1. S $P(^TMP(SUB,$J,0),U,4)=LRCMT
  1. Q
  1. ;
  1. MSG2(MSGTYPE) ;
  1. I 'MSGFLAG D
  1. . K LRMSG
  1. . S LRCMT=$P($G(^TMP("LRCAPPH",$J,0)),U,4)+1,LRMSG(LRCMT)=" "
  1. . S LRCMT=LRCMT+1,LRMSG(LRCMT)=$P(LRN,U,1)_" ["_LRJ_"]"
  1. S LRCMT=LRCMT+1
  1. S LRMSG(LRCMT)="*** Has an inactive "_MSGTYPE_" Code of "_X_".",MSGFLAG=1
  1. Q
  1. ;
  1. MAIL2 ;Send message to G.LMI local mail group
  1. N DUZ,XMDUZ,XMSUB,XMTEXT
  1. Q:'$O(^TMP("LRCAPPH60",$J,0))
  1. S LRCMT=$G(LRCMT)+1,^TMP("LRCAPPH60",$J,LRCMT,0)=" "
  1. S XMSUB="NIGHTLY FILE #60 CPT CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
  1. S XMY("G.LMI")="",XMTEXT="^TMP(""LRCAPPH60"","_$J_","
  1. D ^XMD
  1. Q