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

LRBEBA.m

Go to the documentation of this file. 
  1. LRBEBA ;DALOI/JAH/FHS - SCI, EI, AND LRBEDGX QUESTIONS ; 17-Oct-2014 09:22 ; MKK
  1.  ;;5.2;LAB SERVICE;**291,352,315,1031,1033,1034**;NOV 1, 1997;Build 188
  1.  ;
  1.  ; This routine contains the questions to be asked for 
  1.  ; Service Connected Indicator, Environmental Indicator,
  1.  ; and Diagnosis.
  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 ^ICD9 supported by IA #10082
  1.  ; Reference to ^DIC(9.4 supported by IA #10048
  1.  ;
  1. QUES(LRBEDFN,LRBESMP,LRBESPC,TST,DT,LRBEAR,LRBEDP) ; Start asking questions
  1.  N DIC,DIR,DTOUT,DUOUT,DIRUT,LRBEFMSG,LRBEST,LRBEQT,LRTMP,X,Y
  1.  S:$G(LRBEALO)="" LRBEALO=0 S (LRBEST,LRBEQT)=0
  1.  F  D  Q:LRBEQT
  1.  .;ensure it's active on the date of encounter
  1.  .;S DIC("S")="I $$STATCHK^ICDAPIU(Y,DT)"
  1.  .;
  1.  .D SETDICSD^BLRICDU0(DT)    ; IHS/MSC/MKK - LR*5.2*1034 - Set DIC("S") 
  1.  .;
  1.  .; S LRBEFMSG=" ICD-9 CODE: "
  1.  .S LRBEFMSG=" ICD CODE: "
  1.  .S DIC("A")="Select "_$S(LRBEALO=0:"Primary",1:"Secondary")_LRBEFMSG
  1.  .S DIC="^ICD9(",DIC(0)="AMEQZ" D ^DIC
  1.  .I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT
  1.  .I +Y<1 K DIC S LRBEQT=1 Q:LRBEQT
  1.  .S LRBEDGX=+Y,LRTMP=$P(Y(0),U,1,2)_U
  1.  .; S LRTMP=LRTMP_$P($$ICDDX^ICDCODE(+LRTMP,,,1),U,4)
  1.  . S LRTMP=LRTMP_$P($$ICDDX^ICDEX(+LRTMP,,,1),U,4)    ; IHS/MSC/MKK - LR*5.2*1034
  1.  .S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX)=LRTMP
  1.  .S:'LRBEALO $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,12)=1
  1.  .S LRBEALO=1 D SCI(LRBEDFN,DT,.LRBEQT) Q:LRBEQT
  1.  K LRBEALO
  1.  Q LRBEST
  1.  ;
  1. SCI(LRBEDFN,LRBECDT,LRBEQT) ; Ask the Indicator Questions
  1.  N DIR,DTOUT,DUOUT,DIRUT,I,LRBEA,LRBEB,LRBEBL,LRBESEG,LRBECLY,Y
  1.  I $D(LRBEDP(LRBEDGX)) D  Q
  1.  .S LRBEBL=$L($G(LRBEDP(LRBEDGX)),U)
  1.  .S LRBEB=$P(LRBEDP(LRBEDGX),U,4,LRBEBL)
  1.  .S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,4,LRBEBL)=LRBEB
  1.  D CL^SDCO21(LRBEDFN,LRBECDT_".2359","",.LRBECLY)
  1.  S LRBESEG="3,7,1,2,4,8,5,6"
  1.  F I=1:1:$L(LRBESEG,",") S LRBEA=+$P(LRBESEG,",",I) D  Q:LRBEQT
  1.  .I $D(LRBECLY(LRBEA)) D  Q:LRBEQT
  1.  ..S DIR("A")="  "_$$GETI(LRBEA)
  1.  ..S DIR(0)="YO" D ^DIR
  1.  ..I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT
  1.  ..I +Y=-1 S LRBEQT=1 Q:LRBEQT
  1.  ..S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,LRBEA+3)=Y
  1.  ..S $P(LRBEDP(LRBEDGX),U,LRBEA+3)=Y
  1.  Q
  1.  ;
  1. GETI(LRBEA) ; Get type of Indicator
  1.  N LRBEX,LRBEQUES,LRBEQUS1
  1.  S LRBEQUES="Was treatment related to ",LRBEQUS1="Was treatment for a "
  1.  S:LRBEA=1 LRBEX=LRBEQUES_"Agent Orange exposure"
  1.  S:LRBEA=2 LRBEX=LRBEQUES_"Ionizing Radiation exposure"
  1.  S:LRBEA=3 LRBEX=LRBEQUS1_"Service Connected condition"
  1.  S:LRBEA=4 LRBEX=LRBEQUES_"service in SW Asia"
  1.  S:LRBEA=5 LRBEX=LRBEQUES_"Military Sexual Trauma"
  1.  S:LRBEA=6 LRBEX=LRBEQUES_"Head and Neck Cancer"
  1.  S:LRBEA=7 LRBEX=LRBEQUES_"Combat Vet"
  1.  S:LRBEA=8 LRBEX=LRBEQUES_"Shipboard Hazard And Defense"
  1.  Q LRBEX
  1.  ;
  1. ERRMSG(MT) ; Display Error Message
  1.  N LRBEAST,LRBEFMT,LRBELIN,LRBEMS
  1.  S:MT=-1 LRBEMS="An error occurred. Data may or may not have been processed."
  1.  S:MT<-1 LRBEMS="No data was processed."
  1.  S LRBEMS="* "_LRBEMS_" *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2)
  1.  S LRBELIN=$E(LRBEAST,1,$L(LRBEMS)+1)
  1.  D EN^DDIOL(LRBELIN,"",LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT)
  1.  Q
  1.  ;
  1. SDG1(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEAR) ; Set the diagnois 
  1.  ;                             and indicators file #69
  1.  N LRBEFIL,LRBEIEN,LRBEDFN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM
  1.  N LRDA,LRBEP,DIK,DA
  1.  S DIK="^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRTN_",2,"
  1.  S LRDA=0 F  S LRDA=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRDA)) Q:LRDA<1  D
  1.  . S DA=LRDA D ^DIK
  1.  K DA,DIK
  1.  ;
  1.  S LRBEP=0
  1.  I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
  1.  S:$D(DFN) LRBEDFN=DFN
  1.  S LRBEFIL=69.05,LRBETNUM=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,""),-1)+1,LRBEPDGX=""
  1.  F  S LRBEPDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX)) Q:LRBEPDGX=""  D
  1.  .S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX))
  1.  .I 'LRBEP,'$P(LRBEPTDT,U,12) Q
  1.  .S LRBEP=1
  1.  .S LRBEIEN="+"_LRBETNUM_","_LRTN_","_LRSN_","_LRODT_","
  1.  .S LRFDAIEN(LRBETNUM)=LRBETNUM
  1.  .S LRFDA(99,LRBEFIL,LRBEIEN,.01)=LRBEPDGX
  1.  .S:$P(LRBEPTDT,U,6)'="" LRFDA(99,LRBEFIL,LRBEIEN,1)=$P(LRBEPTDT,U,6)
  1.  .S:$P(LRBEPTDT,U,10)'="" LRFDA(99,LRBEFIL,LRBEIEN,2)=$P(LRBEPTDT,U,10)
  1.  .S:$P(LRBEPTDT,U,4)'="" LRFDA(99,LRBEFIL,LRBEIEN,3)=$P(LRBEPTDT,U,4)
  1.  .S:$P(LRBEPTDT,U,5)'="" LRFDA(99,LRBEFIL,LRBEIEN,4)=$P(LRBEPTDT,U,5)
  1.  .S:$P(LRBEPTDT,U,7)'="" LRFDA(99,LRBEFIL,LRBEIEN,5)=$P(LRBEPTDT,U,7)
  1.  .S:$P(LRBEPTDT,U,8)'="" LRFDA(99,LRBEFIL,LRBEIEN,6)=$P(LRBEPTDT,U,8)
  1.  .S:$P(LRBEPTDT,U,9)'="" LRFDA(99,LRBEFIL,LRBEIEN,7)=$P(LRBEPTDT,U,9)
  1.  .S:$P(LRBEPTDT,U,11)'="" LRFDA(99,LRBEFIL,LRBEIEN,9)=$P(LRBEPTDT,U,11)
  1.  .S:$P(LRBEPTDT,U,12)=1 LRFDA(99,LRBEFIL,LRBEIEN,8)=1         ;Is Primary?
  1.  .S LRBETNUM=LRBETNUM+1
  1.  .I $P(LRBEPTDT,U,12) K LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX) S LRBEPDGX=""
  1.  D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
  1.  Q
  1.  ;
  1. SDOS(LRODT,LRSN,LRTN,LRBECDT) ; Set DOS for CIDC
  1.  N LRBEIEN,LRFDA,LRERR
  1.  S LRBEIEN=LRTN_","_LRSN_","_LRODT_",",LRFDA(99,69.03,LRBEIEN,22)=LRBECDT
  1.  D UPDATE^DIE("","LRFDA(99)","","LRERR")
  1.  Q
  1.  ;
  1. CCPT(LRBECPT,LRBECDT,LRBEAR) ; Check the status of the CPT (CSV)
  1.  ;
  1.  ; Input:
  1.  ;  LRBECPT  -  CPT
  1.  ;  LRBECDT   -  Date To Be Checked ; Collection date/time
  1.  ;  LRBEAR   -  An array passed by reference to hold IEN and Status
  1.  ;
  1.  ; Output:
  1.  ;  ST       -  Status of CPT (Active (1),Inactive (0), or Invalid (-1))
  1.  ;  LRBEAR   -  An array passed by reference to hold IEN and Status
  1.  ;   LRBEAR(CPT)=IEN^NAME^EFFECTIVE DAT^STATUS 
  1.  ;
  1.  N LRBEST,LRBEPTDT
  1.  S LRBEST=""
  1.  S LRBEPTDT=$$CPT^ICPTCOD(LRBECPT,LRBECDT)
  1.  S LRBEST=$P(LRBEPTDT,U,7) I 'LRBEST S LRBEST=-1 Q LRBEST
  1.  S LRBEAR(LRBECPT)=$P(LRBEPTDT,U,1)_U_$P(LRBEPTDT,U,3)_U_$P(LRBEPTDT,U,6)_U_LRBEST
  1.  Q LRBEST
  1.  ;
  1. EMSGCPT(LRBEAR) ; Print out Inactive CPTs
  1.  N CNAM,LRBEASK,LRBEFMT,LRBELIN,LRBECPT,LRBEMS,LRBEMS2,LRBEMS3,LRBEMSG,LRBESP
  1.  S LRBEMSG="Please contact HISYS to correct the Inactive CPTs: "
  1.  S LRBEMS="*  "_LRBEMSG_"  *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2)
  1.  S LRBESP="",$P(LRBESP," ",80)="",LRBELIN=$E(LRBEAST,1,$L(LRBEMS))
  1.  S LRBEMS2="*  "_$E(LRBESP,1,$L(LRBEMSG))_"  *"
  1.  D EN^DDIOL(LRBELIN,"","!"_LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBEMS2,"",LRBEFMT)
  1.  S LRBECPT="" F  S LRBECPT=$O(LRBEAR(LRBECPT)) Q:LRBECPT=""  D
  1.  .Q:$P(LRBEAR(LRBECPT),U,4)'=0
  1.  .S CNAM=$P(LRBEAR(LRBECPT),U,2)
  1.  .S LRBEMS3="*     "_LRBECPT_$E(LRBESP,1,15-$L(LRBECPT))_$E(CNAM,1,30)
  1.  .S LRBEMS3=LRBEMS3_$E(LRBESP,1,($L(LRBEMS)-$L(LRBEMS3))-1)_"*"
  1.  .D EN^DDIOL(LRBEMS3,"",LRBEFMT)
  1.  D EN^DDIOL(LRBEMS2,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT)
  1.  Q
  1.  ;
  1. BAWRK(LRODT,LRSN,LRI,LRBEY,LRTEST,LRBEDEL,LRBEVST,LRBEROLL,ORIEN) ; Send the Billing Information to PCE
  1.  Q:$$MODEXIST^BLRUTIL4("PCE")<1   ; IHS/MSC/MKK - LR*5.2*1033 [00134902]
  1.  ;
  1.  ;input LRBEROLL = 1, if processing from routine LRBEBA5 for roll-up to PCE
  1.  ;input ORIEN = OERR Order #; only passed from WORK^LRBEBA4
  1.  Q:$G(LRCHG)=1
  1.  K ^TMP("LRPXAPI",$J),LRBEAR,LRBEAR1,LRBECPT
  1.  N D0,DA,DIC,DIE,DIR,I,T,X1,X2,X3,X9,Z,Z1,Z2,CNT,VADM,VAIN
  1.  N LRBETEST,LRTN,LRBESB,LRBETST,LRBEPAN,LRBEMSG,LRDBEDGX,LRBESEQ,LRNOP,LRX
  1.  N PXBREQ,LRVN,PXKDONE
  1.  I '$G(LRPKG) D
  1.  . S LRPKG=$$FIND1^DIC(9.4,,"B","LAB SERVICE","B","","ERR")
  1.  I LRPKG<1 D  Q
  1.  . D EN^DDIOL("PCE Error Condition -  Lab Service package not installed","","!")
  1.  N LRBEAR,LRBEDFN,LRBECDT,LRBEU,LRBEX,LRBEZ,LRBETYP,LRBECDT
  1.  N LRBENO,LRBEMOD,LROOS,LRPCECNT,LRI,X,Y,USR
  1.  M LRBETEST=LRTEST
  1.  M LRBESB=LRSB
  1.  S LROOS=$$GET1^DIQ(68,LRAA,.8,"I") I 'LROOS S LROOS=$$GET1^DIQ(69.9,1,.8,"I")
  1.  S LRBEMOD=$$GMOD^LRBEBA2(LRAA)
  1.  S LRBEDEL=$G(LRBEDEL)
  1.  I $G(LRDFN) S:'$G(DFN) DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
  1.  S LRBEDFN=DFN
  1.  S:'$G(LRBEVST) LRBEVST=$P($G(^LRO(69,LRODT,1,LRSN,"PCE")),";")
  1.  S (LRBECDT,LRBEDT)=$J($$GET1^DIQ(69.01,LRSN_","_LRODT_",",10,"I"),7,4)
  1.  S I=0 F  S I=$O(LRBETEST(I)) Q:I<1  D
  1.  . S LRBETST=$P(LRBETEST(I),U,1)
  1.  . S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
  1.  . I LRTN D SDOS(LRODT,LRSN,LRTN,LRBECDT)
  1.  G:$G(LRBENO) KILL
  1.  D BLDAR^LRBEBA3(LRBEDFN,LRODT,LRSN,.LRBEAR,.LRBEY,.LRBETEST,.LRBEPAN,LRBEDEL) G:$G(LRBENO) KILL
  1.  D STDN^LRBEBA2(LRODT,LRSN,.LRBETEST,.LRBEY) G:$G(LRBENO) KILL
  1.  D SOP^LRBEBA2(LRBEDFN,.LRBESB,.LRBEY,.LRBEPAN,$G(LRBEROLL)) G:$G(LRBENO) KILL
  1.  I $D(LRBECPT)>1 D
  1.  .D OPORD^LRBEBAO Q:$G(LRBENO)
  1.  .D OPRES^LRBEBAO(.LRBEAR,.LRBEAR1,LRODT,LRSN,LRBEVST)
  1. KILL ;
  1.  K ^TMP("LRPXAPI",$J)
  1.  K LRPKG,LRBEDIA,LRBEVSIT,LRBEAR,LRBEAR1,LRBEDEL,LRBEDT,LRBEPOS
  1.  K LRBEIEN,LRBEMOD,LRBEPTDT,LRBETM,LRBEDN,LRBESMP,LRBESPC,LRBEDGX,LRBEVST,LROOS,LRBERES
  1.  K ERRDIS,INROOT,SRC,SUB1,SUB2,SUB3,USR
  1.  I '$G(LRBEROLL) K LRBECPT,LRBEY
  1.  Q
  1.  ;
  1. GEDT(LRODT,LRSN,LRBETST) ; Get the Date of Service
  1.  N X,Y,LRBEIEN,DIC,LRBEEDT
  1.  S LRBEEDT=""
  1.  S X=$$GET1^DIQ(60,LRBETST_",",.01)
  1.  S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
  1.  S DIC(0)="Z" D ^DIC I +Y<0 K DIC Q 0
  1.  S LRBEIEN=+Y_","_LRSN_","_LRODT_","
  1.  S LRBEEDT=$$GET1^DIQ(69.03,LRBEIEN,22,"I")
  1.  Q LRBEEDT
  1.  ;
  1. GCDT(LRODT,LRSN) ; Get the collection date/time
  1.  N LRBECDT,LRBEIEN
  1.  S LRBECDT=""
  1.  S LRBEIEN=LRSN_","_LRODT_","
  1.  S LRBECDT=$$GET1^DIQ(69.01,LRBEIEN,10,"I")
  1.  Q LRBECDT