- 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 Feb 18, 2025@23:39:05 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