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

LRBEECPT.m

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