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