LRBEECPT ;VA/DALOI/JAH - Edit CPT associated with CIDC; 3/29/05
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997;Build 188
;
;;VA LR Patche(s): 291,315
;
; To be able to provide a clean claim to the billing application, there
; needs be an association between the test, the specimen, and the
; CPT/HCPCS codes. This routine is designed to allow the user to define
; this associaton.
;
; Reference to EN^DDIOL supported by IA #10142
; Reference to ^DIC supported by IA #10006
; Reference to $$GET1^DIQ supported by IA #2056
; Reference to ^DIR supported by IA #10026
; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
;
STRT ; Start the routine
N DIC,DIR,X,Y,LRBEY,LRBEQUIT,LRBEPNL
N LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
S LRBEQUIT=0
F D Q:LRBEQUIT
.D TST S:Y<1 LRBEQUIT=1 Q:LRBEQUIT
.D EN^DDIOL("","","!")
.S DIR(0)="E" D ^DIR S:Y<1 LRBEQUIT=1
.D EN^DDIOL("","","!")
.D KLL
Q
TST ; Ask the user for the test to work on.
S DIC="^LAB(60,",DIC(0)="AEMQZ" D ^DIC
I Y=-1 K DIC Q ;quit if look-up fails
S LRBEPNL=0
I $P(Y(0),"^",5)="" S LRBEPNL=1 ;Selected test is a panel
S LRBEY=Y D WORK(LRBEY) Q:LRBEQUIT
Q
WORK(LRBEY) ; Start getting the CPT/HCPCS Codes
S LRBETST=$P(LRBEY,U,1),LRBETSTN=$P(LRBEY,U,2)
S LRBEAR2("TEST",LRBETST)=LRBEY
W ! D SPEC(LRBETST) Q:LRBEQUIT
W ! D DEFH(LRBETST,LRBETSTN) Q:LRBEQUIT
W ! D DEFC(LRBETST,LRBETSTN) Q:LRBEQUIT
I LRBEPNL D Q:LRBEQUIT
.W ! D AAMA^LRBEECP1(LRBETST,LRBETSTN)
D DISCPT(.LRBEAR2) Q:LRBEQUIT
Q
SPEC(LRBETST) ; Get the Specimen and CPT of the Test
N A,LRBEAX,LRBESP,LRBESPI,LRBESPE,LRBECPT,LRBEFIL,LRBEFLD,LRBEDT,LRBEMSG
N LRBEQT,LRBEXMSG,LRBEDCPT,LRX,LRBEDESC
D SAR(LRBETST,.LRX)
S A="" F S A=$O(LRX(60.196,A)) Q:A=""!(LRBEQUIT) D
.S LRBESP=$O(LRX(60.196,A,""),-1)
.S LRBESPI=$P(A,",",1)
.S LRBESPE=$P($G(LRX(60.196,A,LRBESP)),"^",1)
.S LRBEDCPT=$P($G(LRX(60.196,A,LRBESP)),"^",2)
.S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
..S LRBEMSG="Enter a CPT for a "_LRBESPE_" specimen: "
..S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT
..I LRBEDCPT="",LRBECPT="@" D WMSG("","ND") Q
..I LRBECPT=LRBEDCPT S LRBEQT=1 Q:LRBEQT
..S:LRBECPT="" LRBEQT=1 Q:LRBEQT
..I $P(LRBECPT,U,1)="@" D Q
...S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3)
...S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC_"^"
...S LRBECPT=LRBECPT_LRBESP_","_LRBESPI_","_LRBETST_","
...S LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI)=LRBECPT,LRBEQT=1
...S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
..S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT
..S LRBEAX=$$GCPT(LRBECPT,LRBEDT) Q:LRBEQUIT
..I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
..I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
..D WMSG($P(LRBEAX,U,3),"V")
..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI),U,1)=LRBEAX,LRBEQT=1
..S LRBEAX=LRBESPE_"^"_LRBEDT
..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"D"),U,1)=LRBEDT
Q
DEFH(LRBETST,LRBETSTN) ; Get the Default HCPCS
N LRBEAX,LRBEQT
S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
.S LRBEAX=$$DHCPCS(LRBETST,LRBETSTN)
.S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT)
.I +LRBEAX=-3 D WMSG("","ND") Q
.I $P(LRBEAX,U,1)="@" D Q
..S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1
.I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT
.I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
.I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
.D WMSG($P(LRBEAX,U,3),"V")
.S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1
Q
DHCPCS(LRBETST,LRBETSTN) ; Get the Default HCPCS code of the Test
N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
S LRBEMSG="Enter a HCPCS code for "_LRBETSTN_": "
S LRBEFIL=60,LRBEFLD=507
S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT
I LRBECPT="" Q LRBECPT
I LRBEDCPT="",LRBECPT="@" Q -3
I LRBECPT="@" D Q LRBECPT
.S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3)
.S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
I LRBECPT=LRBEDCPT Q -2
S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT
S $P(LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS","D"),U,1)=LRBEDT
Q $$GCPT(LRBECPT,LRBEDT)
DEFC(LRBETST,LRBETSTN) ; Get the Default CPT
N LRBEAX,LRBEQT
S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
.S LRBEAX=$$DCPT(LRBETST,LRBETSTN)
.S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT)
.I +LRBEAX=-3 D WMSG("","ND") Q
.I $P(LRBEAX,U,1)="@" D Q
..S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1
.I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT
.I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
.I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
.D WMSG($P(LRBEAX,U,3),"V")
.S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1
Q
DCPT(LRBETST,LRBETSTN) ; Get the Default CPT code of the Test
N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
S LRBEMSG="Enter a Default CPT code for "_LRBETSTN_": "
S LRBEFIL=60,LRBEFLD=506
S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
S LRBECPT=$$RCPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT
I LRBECPT="" Q LRBECPT
I LRBEDCPT="",LRBECPT="@" Q -3
I LRBECPT="@" D Q LRBECPT
.S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3)
.S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
I LRBECPT=LRBEDCPT Q -2
S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT
S $P(LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT","D"),U,1)=LRBEDT
Q $$GCPT(LRBECPT,LRBEDT)
ACPT(LRBEMSG,DCPT) ; Ask for CPT/HCPCS Code
N X,Y,DIR,DUOUT,DTOUT,DIRUT
S DIR("B")=DCPT
S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR
I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT
I Y?1A.4N Q Y
I X="@" Q X
S:Y<1 Y=""
Q Y
ADAT(LRBEMSG) ; Ask for date
N X,Y,DIR,DUOUT,DTOUT,DIRUT
D NOW^%DTC
S DIR(0)="DAO^"_X_"::E",DIR("B")=LRBEMSG
S DIR("A")="Enter Date to be Checked: "
D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y=-1,LRBEQUIT=1
Q Y_"."_$P(%,".",2)
RCPT(LRBEMSG,DCPT) ; Ask for Required default CPT/HCPCS Code
N X,Y,DIR,DUOUT,DTOUT,DIRUT
S DIR("B")=DCPT
S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR
I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT
I X="@" Q X
S:Y<1 Y=""
Q Y
GCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
Q $$CPT^ICPTCOD(CPT,TDAT)
DISCPT(LRBEAR2) ; Display the CPT code in File #60
N LRBEAX,LRBEALO,LRBEBX,DIR,LRBEQT,X,Y
S LRBEQT=0 D EN^DDIOL("","","!!")
S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX=""!(LRBEQT) D
.I $D(LRBEAR2("TEST",LRBEAX))'=11 S LRBEQT=1 Q:LRBEQT
.S LRBEALO=1
.D EN^DDIOL("TEST:","","")
.D EN^DDIOL($E($P(LRBEAR2("TEST",LRBEAX),U,2),1,30),"","?10")
.S LRBEBX="" F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D
..S X=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:X=""
..S Y=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"S"))
..D:LRBEALO
...D EN^DDIOL("SPECIMEN:","","!"),EN^DDIOL("","","!")
..D EN^DDIOL($E(Y,1,15),"","?3")
..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
..D EN^DDIOL("","","!") S LRBEALO=0
.S X=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
.D:X'=""
..D EN^DDIOL("HCPCS:","","")
..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
..D EN^DDIOL("","","!")
.S X=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
.D:X'=""
..D EN^DDIOL("Default CPT:","","")
..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
..D EN^DDIOL("","","!")
.S X=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
.D:X'=""
..D EN^DDIOL("Panel CPT(S) AMA compliant or otherwise billable?:","","")
..D EN^DDIOL($S(X=1:"YES",1:"NO"),"","?60")
..D EN^DDIOL("","","!")
Q:LRBEQT
S DIR("A")="Is this correct",DIR(0)="Y",DIR("B")="YES" D ^DIR
I Y D SCPT(.LRBEAR2)
Q
SCPT(LRBEAR2) ; Set the CPT code in File #60
N LRBEAX,LRBEBX,LRBEFIL1,LRBEFIL2,LRERR,LRFDA,LRBESEQ,LRBEX,LRBEXX
N LRBEXIEN,LRBEDEL
S LRBEFIL1=60,LRBEFIL2=60.196
S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX="" D
.S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
.S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",507)=$P(LRBEX,U,1)
.S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
.S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",506)=$P(LRBEX,U,1)
.S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
.S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",508)=$P(LRBEX,U)
.S LRBEBX=""
.F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D
..S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
..S LRBEDEL=$S($P(LRBEX,U)="@":1,1:0)
..I LRBEDEL D
...S LRBEXIEN=$P(LRBEX,U,4),LRFDAIEN=""
..I 'LRBEDEL D
...S LRBESEQ=$O(^LAB(60,LRBEAX,1,LRBEBX,3,"A"),-1)+1
...S LRBETNUM=$G(LRBETNUM)+1
...S LRBEXIEN="+"_LRBETNUM_","_LRBEBX_","_LRBEAX_","
...S LRFDAIEN(LRBETNUM)=LRBESEQ
...S LRBEXX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"D"))
..S LRFDA(99,LRBEFIL2,LRBEXIEN,.01)=$P(LRBEX,U,1)
..S:'LRBEDEL LRFDA(99,LRBEFIL2,LRBEXIEN,1)=$P(LRBEXX,U,1)
D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
Q
SAR(LRBETST,LRBEAR2) ; Setup Array for Specimen
N A,B,LRBEAR,LRBETNAM,LRBETNUM,LRBETCPT
D GETS^DIQ(60,LRBETST_",","100*","","LRBEAR")
S A="" F S A=$O(LRBEAR(60.01,A)) Q:A="" D
.S LRBETNUM=1,LRBETCPT="",LRBETNAM=$P(LRBEAR(60.01,A,.01),U,1)
.S B="" F S B=$O(LRBEAR(60.196,B)) Q:B="" D
..Q:A'=$P(B,",",2,4)
..S LRBETNUM=$P(B,",",1),LRBETCPT=$G(LRBEAR(60.196,B,.01))
.S LRBEAR2(60.196,$P(A,",",1),LRBETNUM)=LRBETNAM_"^"_LRBETCPT
Q
WMSG(LRBEDESC,LRBEFLG) ; Write Message
N LRBEXMSG
S:LRBEFLG="ND" LRBEXMSG="NOTHING TO DELETE"
S:LRBEFLG="IV" LRBEXMSG="INVALID CPT: "_LRBEDESC
S:LRBEFLG="IA" LRBEXMSG="INACTIVE CPT: NOT ACTIVE FOR THIS DATE"
S:LRBEFLG="V" LRBEXMSG="VALID CPT: "_LRBEDESC
D EN^DDIOL(LRBEXMSG,"","!?$X+5")
Q
KLL ; Kill all variable
K LRBEAX,DIC,DIR,LRBEQT,X,Y
K LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
Q
LRBEECPT ;VA/DALOI/JAH - Edit CPT associated with CIDC; 3/29/05
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997;Build 188
+2 ;
+3 ;;VA LR Patche(s): 291,315
+4 ;
+5 ; To be able to provide a clean claim to the billing application, there
+6 ; needs be an association between the test, the specimen, and the
+7 ; CPT/HCPCS codes. This routine is designed to allow the user to define
+8 ; this associaton.
+9 ;
+10 ; Reference to EN^DDIOL supported by IA #10142
+11 ; Reference to ^DIC supported by IA #10006
+12 ; Reference to $$GET1^DIQ supported by IA #2056
+13 ; Reference to ^DIR supported by IA #10026
+14 ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
+15 ;
STRT ; Start the routine
+1 NEW DIC,DIR,X,Y,LRBEY,LRBEQUIT,LRBEPNL
+2 NEW LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
+3 SET LRBEQUIT=0
+4 FOR
Begin DoDot:1
+5 DO TST
IF Y<1
SET LRBEQUIT=1
IF LRBEQUIT
QUIT
+6 DO EN^DDIOL("","","!")
+7 SET DIR(0)="E"
DO ^DIR
IF Y<1
SET LRBEQUIT=1
+8 DO EN^DDIOL("","","!")
+9 DO KLL
End DoDot:1
IF LRBEQUIT
QUIT
+10 QUIT
TST ; Ask the user for the test to work on.
+1 SET DIC="^LAB(60,"
SET DIC(0)="AEMQZ"
DO ^DIC
+2 ;quit if look-up fails
IF Y=-1
KILL DIC
QUIT
+3 SET LRBEPNL=0
+4 ;Selected test is a panel
IF $PIECE(Y(0),"^",5)=""
SET LRBEPNL=1
+5 SET LRBEY=Y
DO WORK(LRBEY)
IF LRBEQUIT
QUIT
+6 QUIT
WORK(LRBEY) ; Start getting the CPT/HCPCS Codes
+1 SET LRBETST=$PIECE(LRBEY,U,1)
SET LRBETSTN=$PIECE(LRBEY,U,2)
+2 SET LRBEAR2("TEST",LRBETST)=LRBEY
+3 WRITE !
DO SPEC(LRBETST)
IF LRBEQUIT
QUIT
+4 WRITE !
DO DEFH(LRBETST,LRBETSTN)
IF LRBEQUIT
QUIT
+5 WRITE !
DO DEFC(LRBETST,LRBETSTN)
IF LRBEQUIT
QUIT
+6 IF LRBEPNL
Begin DoDot:1
+7 WRITE !
DO AAMA^LRBEECP1(LRBETST,LRBETSTN)
End DoDot:1
IF LRBEQUIT
QUIT
+8 DO DISCPT(.LRBEAR2)
IF LRBEQUIT
QUIT
+9 QUIT
SPEC(LRBETST) ; Get the Specimen and CPT of the Test
+1 NEW A,LRBEAX,LRBESP,LRBESPI,LRBESPE,LRBECPT,LRBEFIL,LRBEFLD,LRBEDT,LRBEMSG
+2 NEW LRBEQT,LRBEXMSG,LRBEDCPT,LRX,LRBEDESC
+3 DO SAR(LRBETST,.LRX)
+4 SET A=""
FOR
SET A=$ORDER(LRX(60.196,A))
IF A=""!(LRBEQUIT)
QUIT
Begin DoDot:1
+5 SET LRBESP=$ORDER(LRX(60.196,A,""),-1)
+6 SET LRBESPI=$PIECE(A,",",1)
+7 SET LRBESPE=$PIECE($GET(LRX(60.196,A,LRBESP)),"^",1)
+8 SET LRBEDCPT=$PIECE($GET(LRX(60.196,A,LRBESP)),"^",2)
+9 SET LRBEQT=0
FOR
Begin DoDot:2
+10 SET LRBEMSG="Enter a CPT for a "_LRBESPE_" specimen: "
+11 SET LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT)
IF LRBEQUIT
QUIT
+12 IF LRBEDCPT=""
IF LRBECPT="@"
DO WMSG("","ND")
QUIT
+13 IF LRBECPT=LRBEDCPT
SET LRBEQT=1
IF LRBEQT
QUIT
+14 IF LRBECPT=""
SET LRBEQT=1
IF LRBEQT
QUIT
+15 IF $PIECE(LRBECPT,U,1)="@"
Begin DoDot:3
+16 SET LRBEDESC=$PIECE($$CPT^ICPTCOD(LRBEDCPT),U,3)
+17 SET LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC_"^"
+18 SET LRBECPT=LRBECPT_LRBESP_","_LRBESPI_","_LRBETST_","
+19 SET LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI)=LRBECPT
SET LRBEQT=1
+20 SET $PIECE(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
End DoDot:3
QUIT
+21 SET LRBEDT=$$ADAT("TODAY")
IF LRBEQUIT
QUIT
+22 SET LRBEAX=$$GCPT(LRBECPT,LRBEDT)
IF LRBEQUIT
QUIT
+23 IF +LRBEAX=-1
DO WMSG($PIECE(LRBEAX,U,2),"IV")
QUIT
+24 IF $PIECE(LRBEAX,U,7)'=1
DO WMSG("INACTIVE","IA")
QUIT
+25 DO WMSG($PIECE(LRBEAX,U,3),"V")
+26 SET $PIECE(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI),U,1)=LRBEAX
SET LRBEQT=1
+27 SET LRBEAX=LRBESPE_"^"_LRBEDT
+28 SET $PIECE(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
+29 SET $PIECE(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"D"),U,1)=LRBEDT
End DoDot:2
IF LRBEQT!(LRBEQUIT)
QUIT
End DoDot:1
+30 QUIT
DEFH(LRBETST,LRBETSTN) ; Get the Default HCPCS
+1 NEW LRBEAX,LRBEQT
+2 SET LRBEQT=0
FOR
Begin DoDot:1
+3 SET LRBEAX=$$DHCPCS(LRBETST,LRBETSTN)
+4 IF LRBEAX=""
SET LRBEQT=1
IF LRBEQT!(LRBEQUIT)
QUIT
+5 IF +LRBEAX=-3
DO WMSG("","ND")
QUIT
+6 IF $PIECE(LRBEAX,U,1)="@"
Begin DoDot:2
+7 SET LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX
SET LRBEQT=1
End DoDot:2
QUIT
+8 IF +LRBEAX=-2
SET LRBEQT=1
IF LRBEQT
QUIT
+9 IF +LRBEAX=-1
DO WMSG($PIECE(LRBEAX,U,2),"IV")
QUIT
+10 IF $PIECE(LRBEAX,U,7)'=1
DO WMSG("INACTIVE","IA")
QUIT
+11 DO WMSG($PIECE(LRBEAX,U,3),"V")
+12 SET LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX
SET LRBEQT=1
End DoDot:1
IF LRBEQT!(LRBEQUIT)
QUIT
+13 QUIT
DHCPCS(LRBETST,LRBETSTN) ; Get the Default HCPCS code of the Test
+1 NEW LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
+2 SET LRBEMSG="Enter a HCPCS code for "_LRBETSTN_": "
+3 SET LRBEFIL=60
SET LRBEFLD=507
+4 SET LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
+5 SET LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT)
IF LRBEQUIT
QUIT LRBEQUIT
+6 IF LRBECPT=""
QUIT LRBECPT
+7 IF LRBEDCPT=""
IF LRBECPT="@"
QUIT -3
+8 IF LRBECPT="@"
Begin DoDot:1
+9 SET LRBEDESC=$PIECE($$CPT^ICPTCOD(LRBEDCPT),U,3)
+10 SET LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
End DoDot:1
QUIT LRBECPT
+11 IF LRBECPT=LRBEDCPT
QUIT -2
+12 SET LRBEDT=$$ADAT("TODAY")
IF LRBEQUIT
QUIT LRBEQUIT
+13 SET $PIECE(LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS","D"),U,1)=LRBEDT
+14 QUIT $$GCPT(LRBECPT,LRBEDT)
DEFC(LRBETST,LRBETSTN) ; Get the Default CPT
+1 NEW LRBEAX,LRBEQT
+2 SET LRBEQT=0
FOR
Begin DoDot:1
+3 SET LRBEAX=$$DCPT(LRBETST,LRBETSTN)
+4 IF LRBEAX=""
SET LRBEQT=1
IF LRBEQT!(LRBEQUIT)
QUIT
+5 IF +LRBEAX=-3
DO WMSG("","ND")
QUIT
+6 IF $PIECE(LRBEAX,U,1)="@"
Begin DoDot:2
+7 SET LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX
SET LRBEQT=1
End DoDot:2
QUIT
+8 IF +LRBEAX=-2
SET LRBEQT=1
IF LRBEQT
QUIT
+9 IF +LRBEAX=-1
DO WMSG($PIECE(LRBEAX,U,2),"IV")
QUIT
+10 IF $PIECE(LRBEAX,U,7)'=1
DO WMSG("INACTIVE","IA")
QUIT
+11 DO WMSG($PIECE(LRBEAX,U,3),"V")
+12 SET LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX
SET LRBEQT=1
End DoDot:1
IF LRBEQT!(LRBEQUIT)
QUIT
+13 QUIT
DCPT(LRBETST,LRBETSTN) ; Get the Default CPT code of the Test
+1 NEW LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
+2 SET LRBEMSG="Enter a Default CPT code for "_LRBETSTN_": "
+3 SET LRBEFIL=60
SET LRBEFLD=506
+4 SET LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
+5 SET LRBECPT=$$RCPT(LRBEMSG,LRBEDCPT)
IF LRBEQUIT
QUIT LRBEQUIT
+6 IF LRBECPT=""
QUIT LRBECPT
+7 IF LRBEDCPT=""
IF LRBECPT="@"
QUIT -3
+8 IF LRBECPT="@"
Begin DoDot:1
+9 SET LRBEDESC=$PIECE($$CPT^ICPTCOD(LRBEDCPT),U,3)
+10 SET LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
End DoDot:1
QUIT LRBECPT
+11 IF LRBECPT=LRBEDCPT
QUIT -2
+12 SET LRBEDT=$$ADAT("TODAY")
IF LRBEQUIT
QUIT LRBEQUIT
+13 SET $PIECE(LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT","D"),U,1)=LRBEDT
+14 QUIT $$GCPT(LRBECPT,LRBEDT)
ACPT(LRBEMSG,DCPT) ; Ask for CPT/HCPCS Code
+1 NEW X,Y,DIR,DUOUT,DTOUT,DIRUT
+2 SET DIR("B")=DCPT
+3 SET DIR("A")=LRBEMSG
SET DIR(0)="FAUO^3:10"
DO ^DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!(X[U)
SET LRBEQUIT=1
QUIT LRBEQUIT
+5 IF Y?1A.4N
QUIT Y
+6 IF X="@"
QUIT X
+7 IF Y<1
SET Y=""
+8 QUIT Y
ADAT(LRBEMSG) ; Ask for date
+1 NEW X,Y,DIR,DUOUT,DTOUT,DIRUT
+2 DO NOW^%DTC
+3 SET DIR(0)="DAO^"_X_"::E"
SET DIR("B")=LRBEMSG
+4 SET DIR("A")="Enter Date to be Checked: "
+5 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y=-1
SET LRBEQUIT=1
+6 QUIT Y_"."_$PIECE(%,".",2)
RCPT(LRBEMSG,DCPT) ; Ask for Required default CPT/HCPCS Code
+1 NEW X,Y,DIR,DUOUT,DTOUT,DIRUT
+2 SET DIR("B")=DCPT
+3 SET DIR("A")=LRBEMSG
SET DIR(0)="FAUO^3:10"
DO ^DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!(X[U)
SET LRBEQUIT=1
QUIT LRBEQUIT
+5 IF X="@"
QUIT X
+6 IF Y<1
SET Y=""
+7 QUIT Y
GCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
+1 QUIT $$CPT^ICPTCOD(CPT,TDAT)
DISCPT(LRBEAR2) ; Display the CPT code in File #60
+1 NEW LRBEAX,LRBEALO,LRBEBX,DIR,LRBEQT,X,Y
+2 SET LRBEQT=0
DO EN^DDIOL("","","!!")
+3 SET LRBEAX=""
FOR
SET LRBEAX=$ORDER(LRBEAR2("TEST",LRBEAX))
IF LRBEAX=""!(LRBEQT)
QUIT
Begin DoDot:1
+4 IF $DATA(LRBEAR2("TEST",LRBEAX))'=11
SET LRBEQT=1
IF LRBEQT
QUIT
+5 SET LRBEALO=1
+6 DO EN^DDIOL("TEST:","","")
+7 DO EN^DDIOL($EXTRACT($PIECE(LRBEAR2("TEST",LRBEAX),U,2),1,30),"","?10")
+8 SET LRBEBX=""
FOR
SET LRBEBX=$ORDER(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
IF LRBEBX=""
QUIT
Begin DoDot:2
+9 SET X=$GET(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
IF X=""
QUIT
+10 SET Y=$GET(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"S"))
+11 IF LRBEALO
Begin DoDot:3
+12 DO EN^DDIOL("SPECIMEN:","","!")
DO EN^DDIOL("","","!")
End DoDot:3
+13 DO EN^DDIOL($EXTRACT(Y,1,15),"","?3")
+14 DO EN^DDIOL($EXTRACT($PIECE(X,U,3),1,35),"","?20")
+15 DO EN^DDIOL($SELECT($PIECE(X,U,1)="@":$PIECE(X,U,2)_" (DELETE)",1:$PIECE(X,U,1)),"","?60")
+16 DO EN^DDIOL("","","!")
SET LRBEALO=0
End DoDot:2
+17 SET X=$GET(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
+18 IF X'=""
Begin DoDot:2
+19 DO EN^DDIOL("HCPCS:","","")
+20 DO EN^DDIOL($EXTRACT($PIECE(X,U,3),1,35),"","?20")
+21 DO EN^DDIOL($SELECT($PIECE(X,U,1)="@":$PIECE(X,U,2)_" (DELETE)",1:$PIECE(X,U,1)),"","?60")
+22 DO EN^DDIOL("","","!")
End DoDot:2
+23 SET X=$GET(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
+24 IF X'=""
Begin DoDot:2
+25 DO EN^DDIOL("Default CPT:","","")
+26 DO EN^DDIOL($EXTRACT($PIECE(X,U,3),1,35),"","?20")
+27 DO EN^DDIOL($SELECT($PIECE(X,U,1)="@":$PIECE(X,U,2)_" (DELETE)",1:$PIECE(X,U,1)),"","?60")
+28 DO EN^DDIOL("","","!")
End DoDot:2
+29 SET X=$GET(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
+30 IF X'=""
Begin DoDot:2
+31 DO EN^DDIOL("Panel CPT(S) AMA compliant or otherwise billable?:","","")
+32 DO EN^DDIOL($SELECT(X=1:"YES",1:"NO"),"","?60")
+33 DO EN^DDIOL("","","!")
End DoDot:2
End DoDot:1
+34 IF LRBEQT
QUIT
+35 SET DIR("A")="Is this correct"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
+36 IF Y
DO SCPT(.LRBEAR2)
+37 QUIT
SCPT(LRBEAR2) ; Set the CPT code in File #60
+1 NEW LRBEAX,LRBEBX,LRBEFIL1,LRBEFIL2,LRERR,LRFDA,LRBESEQ,LRBEX,LRBEXX
+2 NEW LRBEXIEN,LRBEDEL
+3 SET LRBEFIL1=60
SET LRBEFIL2=60.196
+4 SET LRBEAX=""
FOR
SET LRBEAX=$ORDER(LRBEAR2("TEST",LRBEAX))
IF LRBEAX=""
QUIT
Begin DoDot:1
+5 SET LRBEX=$GET(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
+6 IF LRBEX'=""
SET LRFDA(99,LRBEFIL1,LRBEAX_",",507)=$PIECE(LRBEX,U,1)
+7 SET LRBEX=$GET(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
+8 IF LRBEX'=""
SET LRFDA(99,LRBEFIL1,LRBEAX_",",506)=$PIECE(LRBEX,U,1)
+9 SET LRBEX=$GET(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
+10 IF LRBEX'=""
SET LRFDA(99,LRBEFIL1,LRBEAX_",",508)=$PIECE(LRBEX,U)
+11 SET LRBEBX=""
+12 FOR
SET LRBEBX=$ORDER(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
IF LRBEBX=""
QUIT
Begin DoDot:2
+13 SET LRBEX=$GET(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
+14 SET LRBEDEL=$SELECT($PIECE(LRBEX,U)="@":1,1:0)
+15 IF LRBEDEL
Begin DoDot:3
+16 SET LRBEXIEN=$PIECE(LRBEX,U,4)
SET LRFDAIEN=""
End DoDot:3
+17 IF 'LRBEDEL
Begin DoDot:3
+18 SET LRBESEQ=$ORDER(^LAB(60,LRBEAX,1,LRBEBX,3,"A"),-1)+1
+19 SET LRBETNUM=$GET(LRBETNUM)+1
+20 SET LRBEXIEN="+"_LRBETNUM_","_LRBEBX_","_LRBEAX_","
+21 SET LRFDAIEN(LRBETNUM)=LRBESEQ
+22 SET LRBEXX=$GET(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"D"))
End DoDot:3
+23 SET LRFDA(99,LRBEFIL2,LRBEXIEN,.01)=$PIECE(LRBEX,U,1)
+24 IF 'LRBEDEL
SET LRFDA(99,LRBEFIL2,LRBEXIEN,1)=$PIECE(LRBEXX,U,1)
End DoDot:2
End DoDot:1
+25 DO UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
+26 QUIT
SAR(LRBETST,LRBEAR2) ; Setup Array for Specimen
+1 NEW A,B,LRBEAR,LRBETNAM,LRBETNUM,LRBETCPT
+2 DO GETS^DIQ(60,LRBETST_",","100*","","LRBEAR")
+3 SET A=""
FOR
SET A=$ORDER(LRBEAR(60.01,A))
IF A=""
QUIT
Begin DoDot:1
+4 SET LRBETNUM=1
SET LRBETCPT=""
SET LRBETNAM=$PIECE(LRBEAR(60.01,A,.01),U,1)
+5 SET B=""
FOR
SET B=$ORDER(LRBEAR(60.196,B))
IF B=""
QUIT
Begin DoDot:2
+6 IF A'=$PIECE(B,",",2,4)
QUIT
+7 SET LRBETNUM=$PIECE(B,",",1)
SET LRBETCPT=$GET(LRBEAR(60.196,B,.01))
End DoDot:2
+8 SET LRBEAR2(60.196,$PIECE(A,",",1),LRBETNUM)=LRBETNAM_"^"_LRBETCPT
End DoDot:1
+9 QUIT
WMSG(LRBEDESC,LRBEFLG) ; Write Message
+1 NEW LRBEXMSG
+2 IF LRBEFLG="ND"
SET LRBEXMSG="NOTHING TO DELETE"
+3 IF LRBEFLG="IV"
SET LRBEXMSG="INVALID CPT: "_LRBEDESC
+4 IF LRBEFLG="IA"
SET LRBEXMSG="INACTIVE CPT: NOT ACTIVE FOR THIS DATE"
+5 IF LRBEFLG="V"
SET LRBEXMSG="VALID CPT: "_LRBEDESC
+6 DO EN^DDIOL(LRBEXMSG,"","!?$X+5")
+7 QUIT
KLL ; Kill all variable
+1 KILL LRBEAX,DIC,DIR,LRBEQT,X,Y
+2 KILL LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
+3 QUIT
