BLRRLEDI ;cmi/flag/maw - BLR REFERENCE LAB LEDI UTILITIES ; 02-Nov-2015 13:43 ; MAW
;;5.2;IHS LABORATORY;**1027,1031,1033,1034,1035,1037**;NOV 01, 1997;Build 4
;
;
ORD(OR,PAT) ;-- lets create the order stub here
I $O(^BLRRLO("B",OR,0)) Q $O(^BLRRLO("B",OR,0))
N FDA,FIENS,FERR
S FIENS=""
S FDA(9009026.3,"+1,",.01)=OR
S FDA(9009026.3,"+1,",.04)=PAT
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
I $D(FERR(1)) W !,"Error adding order number "_OR_" to Reference Lab Order file" Q ""
Q $G(FIENS(1))
;
ACC(AC,OR,PAT,CDT) ;-- add the accession number to the order
N FI,FIENS,FDA,FERR,ORI
I '$G(CDT) S CDT=DT
S FI=$O(^BLRRLO("B",OR,0))
I '$G(FI) S FI=$$ORD(OR,PAT)
I '$G(FI) Q ""
I $P($G(^BLRRLO(FI,0)),U,4)'=PAT Q ""
S FIENS=FI_","
S FDA(9009026.33,"?+2,"_FIENS,.01)=AC
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
I $D(FERR(1)) W !,"Error adding accession number "_AC_" to Order "_OR_" in the Reference Lab Order file" Q ""
Q $G(FI)
;
DX(OR) ;-- lets add/edit diagnosis here
;need to modify this here to look and see if there are diagnosis already here and if so bring them up to modify
N ORI
K BLRDFLG
S ORI=$O(^BLRRLO("B",OR,0))
I $O(^BLRRLO(ORI,1,"B",0)) D
. S BLRDXS=1
. S BLRDFLG=$$DXV(ORI)
I $G(BLRDFLG)]"",$G(BLRDFLG)="D" D DELDX,DX(OR)
I $G(BLRDFLG)]"",$G(BLRDFLG)'="A" Q
S DA(1)=ORI
S DIC(0)="AELMQZ"
S DIC("A")="Enter ICD Diagnosis code for billing: "
S DIC="^BLRRLO("_ORI_",1,"
S DIC("DR")="1////"_$G(BLRTS)
D ^DIC
Q:Y<0
S BLRDXS=1
D DX(OR) ;allow adding until they ^ out
Q
;
DXV(RI) ;-- display the diagnosis and ask if they want to delete or add
N RDA,RCNT,RDATA,RDX
S RCNT=0
K BLRRLDAT
W !,"There are existing Diagnosis attached to this order",!
S RDA=0 F S RDA=$O(^BLRRLO(ORI,1,RDA)) Q:'RDA D
. S RCNT=RCNT+1
. S RDATA=$G(^BLRRLO(ORI,1,RDA,0))
. S BLRRLDAT(RCNT)=RDA
. ;remove comments below for proposed change 1034
. I $D(^ICDS(0)) S RDX=$$ICDDX^ICDEX($P(RDATA,U),DT)
. I '$D(^ICDS(0)) S RDX=$$ICDDX^ICDCODE($P(RDATA,U),DT)
. ;W !,RCNT_") Dx: "_$$GET1^DIQ(80,$P(RDATA,U),.01),?15,"Test: "_$$GET1^DIQ(60,$P(RDATA,U,2),.01)
. W !,RCNT_") Dx: "_$P(RDX,U,2),?15,"Text: "_$P(RDX,U,4)
K DIR
S DIR(0)="S^A:Add a New DX;D:Delete an Existing DX;U:Use existing DX",DIR("A")="Select an Option"
S DIR("B")="U"
D ^DIR
Q:$D(DIRUT) 0
Q Y
;
DELDX ;-- delete an existing dx in the file
N DXD,DAT
K DIR
S DIR(0)="N^1:"_$O(BLRRLDAT(""),-1),DIR("A")="Delete which DX"
D ^DIR
Q:$D(DIRUT)
S DAT=+Y
S DA=+$G(BLRRLDAT(DAT))
S DIK="^BLRRLO("_ORI_",1,"
S DA(1)=ORI
D ^DIK
Q
;
CLIENT(OR,AC) ;client account number
I +$G(BLRAGUI) Q $$CLIENTG(OR,AC)
N BLRCLCNT
S BLRCLCNT=$$CLCNT(DUZ(2))
I $G(BLRCLCNT)=1 D
. S BLRRL("CLIENT")=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
. I $G(BLRRL("CLIENT"))="" S BLRRL("CLIENT")=$P($G(^BLRRL(BLRRL("RL"),0)),U,13)
I $G(BLRCLCNT)>1 D
. W !,"Please select the appropriate account number for this accession"
. N BLRRLD
. S BLRRLD=0 F S BLRRLD=$O(BLRCLA(BLRRLD)) Q:'BLRRLD D
.. W !,BLRRLD_") "_$G(BLRCLA(BLRRLD))
. K DIR
. S DIR(0)="N^1:"_$G(BLRCLCNT),DIR("A")="Which account number for this accession "
. D ^DIR
. Q:$D(DIRUT)
. S BLRRL("CLIENT")=$G(BLRCLA(+Y))
. S BLRRLCLT=BLRRL("CLIENT")
I $G(BLRRL("CLIENT"))="" D CLIENT(OR,AC)
S BLRRLCLA=1
N FDA,FIENS,FERR,FI
S FI=$O(^BLRRLO("B",OR,0))
S FIENS=FI_","
S FDA(9009026.3,FIENS,.03)=$G(BLRRL("CLIENT"))
D FILE^DIE("K","FDA","FERR(1)")
I $D(FERR(1)) W !,"Error adding client account number "_$G(BLRRL("CLIENT"))_" to Order "_OR_" in the Reference Lab Order file" Q ""
Q $G(FI)
;
CLIENTG(OR,AC) ;store client account number (GUI)
N BLRCLCNT
S BLRCLCNT=$$CLCNT(DUZ(2))
S BLRRL("CLIENT")=BLRRLCLA
S BLRRLCLT=BLRRL("CLIENT")
S BLRRLCLA=1
N FDA,FIENS,FERR,FI
S FI=$O(^BLRRLO("B",OR,0))
Q:$P($G(^BLRRLO(FI,0)),U,3)]""
S FIENS=FI_","
S FDA(9009026.3,FIENS,.03)=$G(BLRRL("CLIENT"))
D FILE^DIE("K","FDA","FERR(1)")
;I $D(FERR(1)) W !,"Error adding client account number "_$G(BLRRL("CLIENT"))_" to Order "_OR_" in the Reference Lab Order file" Q ""
Q $G(FI)
;
CLCNT(DZ2) ;-- get the number of client account numbers to see if we need to prompt
N BLRRLDA,BLRCLC
S BLRCLC=0
S BLRRLDA=0 F S BLRRLDA=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DZ2),"RLCA","B",BLRRLDA)) Q:BLRRLDA="" D
. S BLRCLC=BLRCLC+1
. S BLRCLA(BLRCLC)=BLRRLDA
Q +$G(BLRCLC)
;
BTP(OR,BT) ;-- file the bill type
N FI,FIENS,FDA,FERR
S FI=$O(^BLRRLO("B",OR,0))
S FIENS=FI_","
I $G(BT)="" S BT="C"
S FDA(9009026.3,FIENS,.05)=BT
D FILE^DIE("K","FDA","FERR(1)")
I $D(FERR(1)) W !,"Error adding bill type "_BT_" to Order "_OR_" in the Reference Lab Order file" Q ""
Q $G(FI)
;
BILL(BTP,OR,AC,CDT) ;-- this is where we ask billing type
I $G(BLRGUI) D Q
.; I $G(BLRRL("BILL TYPE"))="" I "CTP"[$G(BLRBT) S BLRRL("BILL TYPE")=BLRBT,BLRINS=1 S BT=$$BTP(OR,BTP) Q
.I $G(BLRRL("BILL TYPE"))="" I $L($G(BLRBT)),"CTP"[$G(BLRBT) S BLRRL("BILL TYPE")=BLRBT,BLRINS=1 S BT=$$BTP(OR,BTP) Q ; IHS/MSC/MKK - LR*5.2*1034
.I $G(BLRRL("BILL TYPE"))="" S BLRRL("BILL TYPE")=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
.S:$G(BLRRL("BILL TYPE"))'="" BLRINS=1
Q:$G(BLRGUI)
N BT,ORI
I '$G(CDT) S CDT=$P($G(^BLRRLO($O(^BLRRLO("B",OR,0)),0)),U,6)
I '$G(CDT) S CDT=DT
I BTP'="T" D Q
. S BT=$$BTP(OR,BTP)
K DIR,DIRUT,DTOUT,DUOUT ; Clear DIR array and special FileMan variables - IHS/MSC/MKK - LR*5.2*1034
S DIR(0)="S^C:Client;T:Third Party;P:Patient"
S DIR("A")="Which Party is Responsible for Billing: "
S DIR("B")=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
D ^DIR
I $D(DIRUT) K Y S Y="C",Y(0)="Client" ; If user exits or Times Out, reset Y variable - IHS/MSC/MKK - LR*5.2*1034
S BLRRL("BILL TYPE")=Y(0)
S BT=$$BTP(OR,$G(Y))
;I $D(DIRUT) S BLRRL("BILL TYPE")="Client" ; Comment out line - IHS/MSC/MKK LR*5.2*1034
K DIR
I $E(BLRRL("BILL TYPE"),1,1)="T" D
. S ORI=$O(^BLRRLO("B",OR,0))
. I $O(^BLRRLO(ORI,1,"B",0)) S BLRDXS=1
. D INS(OR,AC,DFN,CDT,0)
I $E(BLRRL("BILL TYPE"),1,1)="T",'$G(BLRDXS) W !,"You must select an ICD Diagnosis if Bill Type is Third Party" D DX(OR)
I $E(BLRRL("BILL TYPE"),1,1)="T",'$G(BLRINSS) W !,"You must select an Insurer if Bill Type is Third Party" D BILL(BTP,OR,AC)
S BLRINS=1
Q
;
INS(OR,AC,PAT,CD,ED) ;-- lets get a list of selectable insurances for the patient and if set for auto select pick the first one in sequence
;we must also setup the BLRRL insurance array and diagnosis array for GIS
N INSS,BT,BDA,BDAC,BLRRLDA,BLRNUM
K AGINS,AGINSNN,AGINSN ;ihs/cmi/maw 07/24/2013 patch 1033
S BDAC=0
S DFN=PAT
D ^AGINS
I '$D(AGINS(1)),$E($G(BLRRL("BILL TYPE")),1,1)="T" D Q
. W !,"Patient has No Insurance on file, changing Bill Type to Client"
. S BT=$$BTP(OR,"C")
I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,21) D Q ;get flag for insurance
. W !,"Now applying Sequenced Insurer to Accession"
. I '$G(CD) S CD=DT
. D SEQINS(.AGINS,PAT,CD)
. I '$D(BLRSEQ(1)) D Q
.. W !,"Patient Insurance has not been Sequenced, changing Bill Type to Client"
.. S BT=$$BTP(OR,"C")
. S BDA=0 F S BDA=$O(BLRSEQ(BDA)) Q:'BDA!(BDAC>3) D
.. S BDAC=BDAC+1
.. S INSS=$TR($G(BLRSEQ(BDA)),"^","~") ;have to switch to ~ for filing
.. D UPINS(OR,AC,PAT,INSS)
S BLRRLDA=0 F S BLRRLDA=$O(AGINS(BLRRLDA)) Q:'BLRRLDA D
. S BLRNUM=BLRRLDA
. W !,BLRRLDA_")"_$P(AGINS(BLRRLDA),U)_$S($P(AGINS(BLRRLDA),U,4)]"":"("_$E($P(AGINS(BLRRLDA),U,4),1,2)_")",1:"")
. W ?30,"Policy #: "_$P(AGINS(BLRRLDA),U,9)
. W ?50,"Elg/Exp Date: "_$S($P(AGINS(BLRRLDA),U,5)>0:$$FMTE^XLFDT($P(AGINS(BLRRLDA),U,5)),1:"")_"/"_$S($P(AGINS(BLRRLDA),U,6)>0:$$FMTE^XLFDT($P(AGINS(BLRRLDA),U,6)),1:"")
K DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="N"_$S(ED:"O",1:"")_"^1:"_+$G(BLRNUM),DIR("A")="Select the insurer for this accession: "
D ^DIR
Q:$D(DIRUT)
Q:Y<0
S BLRINS=+Y
S INSS=$TR($G(AGINS(BLRINS)),"^","~") ;have to switch to ~ for filing
D UPINS(OR,AC,PAT,INSS)
Q
;
UPINS(O,A,P,S) ;-- update the entry in the BLR REFERENCE LAB ORDER/ACCESSION file
N FI,FDA,FIENS,FERR
S FI=$O(^BLRRLO("B",O,0))
I '$G(FI) S FI=$O(^BLRRLO("ACC",A,0))
S FIENS=FI_","
S FDA(9009026.32,"+2,"_FIENS,.01)=S
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
I $D(FERR(1)) W !,"Error adding insurance to Order "_OR_" in the Reference Lab Order file"
S BLRINSS=1
Q
;
SEQINS(BINS,PT,RLCDT) ;-- lets go through sequencing insurers
Q:'$O(BINS(""))
K BLRSEQ ;ihs/cmi/maw 10/07/2013 patch 1033
N BDA
S BDA=0 F S BDA=$O(BINS(BDA)) Q:'BDA D
. N BINI,SEQ,POLI
. S BINI=$P(BINS(BDA),U,2)
. S POLI=$P(BINS(BDA),U,9)
. S SEQ=$$FNDSEQ(BINI,PT,POLI,RLCDT)
. Q:'SEQ
. S BLRSEQ(SEQ)=$G(BINS(BDA))
Q
;
FNDSEQ(BN,PTI,POL,CDT) ;-- find the category prioritization
N SQDA,EFF,SQPRI
S EFF=$O(^AUPNICP("EFF",PTI,"M",""),-1)
I '$G(EFF) Q ""
S SQDA=0 F S SQDA=$O(^AUPNICP("EFF",PTI,"M",EFF,SQDA)) Q:'SQDA!($G(SQPRI)) D
. N SQDATA,SQPAT,SQPOL,SQINS
. S SQDATA=$G(^AUPNICP(SQDA,0))
. S SQPAT=$P(SQDATA,U,2)
. S SQINS=$P(SQDATA,U,3)
. S SQPOL=$P(SQDATA,U,10)
. Q:SQPAT'=PTI
. Q:SQINS'=BN
. Q:SQPOL'=POL
. S SQPRI=$P(SQDATA,U,5)
Q $G(SQPRI)
;
EORD ;-- Edit the Order
K DIC,DIE
N DATA,ORD,ACC,PAT,CDT
S DIC(0)="AEMQZ"
S DIC("A")="Edit insurance/billing information for which order number: "
S DIC="^BLRRLO("
D ^DIC
Q:Y<0
S DIE=DIC
S DA=+Y
S DR=".03;.05;1"
D ^DIE
S DATA=$G(^BLRRLO(DA,0))
S ORD=$P(DATA,U)
S ACC=$P(DATA,U,2)
S PAT=$P(DATA,U,4)
S CDT=$P(DATA,U,6)
D COINS(DA)
D INS(ORD,ACC,PAT,CDT,1)
D EORD
Q
;
COINS(IN) ;-- clean out insurances before reselecting
N BDA
S DIK="^BLRRLO("_IN_",2,"
S DA(1)=IN
S BDA=0 F S BDA=$O(^BLRRLO(IN,2,BDA)) Q:'BDA D
. S DA=BDA
. D ^DIK
Q
;
BLRRLEDI ;cmi/flag/maw - BLR REFERENCE LAB LEDI UTILITIES ; 02-Nov-2015 13:43 ; MAW
+1 ;;5.2;IHS LABORATORY;**1027,1031,1033,1034,1035,1037**;NOV 01, 1997;Build 4
+2 ;
+3 ;
ORD(OR,PAT) ;-- lets create the order stub here
+1 IF $ORDER(^BLRRLO("B",OR,0))
QUIT $ORDER(^BLRRLO("B",OR,0))
+2 NEW FDA,FIENS,FERR
+3 SET FIENS=""
+4 SET FDA(9009026.3,"+1,",.01)=OR
+5 SET FDA(9009026.3,"+1,",.04)=PAT
+6 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+7 IF $DATA(FERR(1))
WRITE !,"Error adding order number "_OR_" to Reference Lab Order file"
QUIT ""
+8 QUIT $GET(FIENS(1))
+9 ;
ACC(AC,OR,PAT,CDT) ;-- add the accession number to the order
+1 NEW FI,FIENS,FDA,FERR,ORI
+2 IF '$GET(CDT)
SET CDT=DT
+3 SET FI=$ORDER(^BLRRLO("B",OR,0))
+4 IF '$GET(FI)
SET FI=$$ORD(OR,PAT)
+5 IF '$GET(FI)
QUIT ""
+6 IF $PIECE($GET(^BLRRLO(FI,0)),U,4)'=PAT
QUIT ""
+7 SET FIENS=FI_","
+8 SET FDA(9009026.33,"?+2,"_FIENS,.01)=AC
+9 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+10 IF $DATA(FERR(1))
WRITE !,"Error adding accession number "_AC_" to Order "_OR_" in the Reference Lab Order file"
QUIT ""
+11 QUIT $GET(FI)
+12 ;
DX(OR) ;-- lets add/edit diagnosis here
+1 ;need to modify this here to look and see if there are diagnosis already here and if so bring them up to modify
+2 NEW ORI
+3 KILL BLRDFLG
+4 SET ORI=$ORDER(^BLRRLO("B",OR,0))
+5 IF $ORDER(^BLRRLO(ORI,1,"B",0))
Begin DoDot:1
+6 SET BLRDXS=1
+7 SET BLRDFLG=$$DXV(ORI)
End DoDot:1
+8 IF $GET(BLRDFLG)]""
IF $GET(BLRDFLG)="D"
DO DELDX
DO DX(OR)
+9 IF $GET(BLRDFLG)]""
IF $GET(BLRDFLG)'="A"
QUIT
+10 SET DA(1)=ORI
+11 SET DIC(0)="AELMQZ"
+12 SET DIC("A")="Enter ICD Diagnosis code for billing: "
+13 SET DIC="^BLRRLO("_ORI_",1,"
+14 SET DIC("DR")="1////"_$GET(BLRTS)
+15 DO ^DIC
+16 IF Y<0
QUIT
+17 SET BLRDXS=1
+18 ;allow adding until they ^ out
DO DX(OR)
+19 QUIT
+20 ;
DXV(RI) ;-- display the diagnosis and ask if they want to delete or add
+1 NEW RDA,RCNT,RDATA,RDX
+2 SET RCNT=0
+3 KILL BLRRLDAT
+4 WRITE !,"There are existing Diagnosis attached to this order",!
+5 SET RDA=0
FOR
SET RDA=$ORDER(^BLRRLO(ORI,1,RDA))
IF 'RDA
QUIT
Begin DoDot:1
+6 SET RCNT=RCNT+1
+7 SET RDATA=$GET(^BLRRLO(ORI,1,RDA,0))
+8 SET BLRRLDAT(RCNT)=RDA
+9 ;remove comments below for proposed change 1034
+10 IF $DATA(^ICDS(0))
SET RDX=$$ICDDX^ICDEX($PIECE(RDATA,U),DT)
+11 IF '$DATA(^ICDS(0))
SET RDX=$$ICDDX^ICDCODE($PIECE(RDATA,U),DT)
+12 ;W !,RCNT_") Dx: "_$$GET1^DIQ(80,$P(RDATA,U),.01),?15,"Test: "_$$GET1^DIQ(60,$P(RDATA,U,2),.01)
+13 WRITE !,RCNT_") Dx: "_$PIECE(RDX,U,2),?15,"Text: "_$PIECE(RDX,U,4)
End DoDot:1
+14 KILL DIR
+15 SET DIR(0)="S^A:Add a New DX;D:Delete an Existing DX;U:Use existing DX"
SET DIR("A")="Select an Option"
+16 SET DIR("B")="U"
+17 DO ^DIR
+18 IF $DATA(DIRUT)
QUIT 0
+19 QUIT Y
+20 ;
DELDX ;-- delete an existing dx in the file
+1 NEW DXD,DAT
+2 KILL DIR
+3 SET DIR(0)="N^1:"_$ORDER(BLRRLDAT(""),-1)
SET DIR("A")="Delete which DX"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET DAT=+Y
+7 SET DA=+$GET(BLRRLDAT(DAT))
+8 SET DIK="^BLRRLO("_ORI_",1,"
+9 SET DA(1)=ORI
+10 DO ^DIK
+11 QUIT
+12 ;
CLIENT(OR,AC) ;client account number
+1 IF +$GET(BLRAGUI)
QUIT $$CLIENTG(OR,AC)
+2 NEW BLRCLCNT
+3 SET BLRCLCNT=$$CLCNT(DUZ(2))
+4 IF $GET(BLRCLCNT)=1
Begin DoDot:1
+5 SET BLRRL("CLIENT")=$ORDER(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
+6 IF $GET(BLRRL("CLIENT"))=""
SET BLRRL("CLIENT")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U,13)
End DoDot:1
+7 IF $GET(BLRCLCNT)>1
Begin DoDot:1
+8 WRITE !,"Please select the appropriate account number for this accession"
+9 NEW BLRRLD
+10 SET BLRRLD=0
FOR
SET BLRRLD=$ORDER(BLRCLA(BLRRLD))
IF 'BLRRLD
QUIT
Begin DoDot:2
+11 WRITE !,BLRRLD_") "_$GET(BLRCLA(BLRRLD))
End DoDot:2
+12 KILL DIR
+13 SET DIR(0)="N^1:"_$GET(BLRCLCNT)
SET DIR("A")="Which account number for this accession "
+14 DO ^DIR
+15 IF $DATA(DIRUT)
QUIT
+16 SET BLRRL("CLIENT")=$GET(BLRCLA(+Y))
+17 SET BLRRLCLT=BLRRL("CLIENT")
End DoDot:1
+18 IF $GET(BLRRL("CLIENT"))=""
DO CLIENT(OR,AC)
+19 SET BLRRLCLA=1
+20 NEW FDA,FIENS,FERR,FI
+21 SET FI=$ORDER(^BLRRLO("B",OR,0))
+22 SET FIENS=FI_","
+23 SET FDA(9009026.3,FIENS,.03)=$GET(BLRRL("CLIENT"))
+24 DO FILE^DIE("K","FDA","FERR(1)")
+25 IF $DATA(FERR(1))
WRITE !,"Error adding client account number "_$GET(BLRRL("CLIENT"))_" to Order "_OR_" in the Reference Lab Order file"
QUIT ""
+26 QUIT $GET(FI)
+27 ;
CLIENTG(OR,AC) ;store client account number (GUI)
+1 NEW BLRCLCNT
+2 SET BLRCLCNT=$$CLCNT(DUZ(2))
+3 SET BLRRL("CLIENT")=BLRRLCLA
+4 SET BLRRLCLT=BLRRL("CLIENT")
+5 SET BLRRLCLA=1
+6 NEW FDA,FIENS,FERR,FI
+7 SET FI=$ORDER(^BLRRLO("B",OR,0))
+8 IF $PIECE($GET(^BLRRLO(FI,0)),U,3)]""
QUIT
+9 SET FIENS=FI_","
+10 SET FDA(9009026.3,FIENS,.03)=$GET(BLRRL("CLIENT"))
+11 DO FILE^DIE("K","FDA","FERR(1)")
+12 ;I $D(FERR(1)) W !,"Error adding client account number "_$G(BLRRL("CLIENT"))_" to Order "_OR_" in the Reference Lab Order file" Q ""
+13 QUIT $GET(FI)
+14 ;
CLCNT(DZ2) ;-- get the number of client account numbers to see if we need to prompt
+1 NEW BLRRLDA,BLRCLC
+2 SET BLRCLC=0
+3 SET BLRRLDA=0
FOR
SET BLRRLDA=$ORDER(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DZ2),"RLCA","B",BLRRLDA))
IF BLRRLDA=""
QUIT
Begin DoDot:1
+4 SET BLRCLC=BLRCLC+1
+5 SET BLRCLA(BLRCLC)=BLRRLDA
End DoDot:1
+6 QUIT +$GET(BLRCLC)
+7 ;
BTP(OR,BT) ;-- file the bill type
+1 NEW FI,FIENS,FDA,FERR
+2 SET FI=$ORDER(^BLRRLO("B",OR,0))
+3 SET FIENS=FI_","
+4 IF $GET(BT)=""
SET BT="C"
+5 SET FDA(9009026.3,FIENS,.05)=BT
+6 DO FILE^DIE("K","FDA","FERR(1)")
+7 IF $DATA(FERR(1))
WRITE !,"Error adding bill type "_BT_" to Order "_OR_" in the Reference Lab Order file"
QUIT ""
+8 QUIT $GET(FI)
+9 ;
BILL(BTP,OR,AC,CDT) ;-- this is where we ask billing type
+1 IF $GET(BLRGUI)
Begin DoDot:1
+2 ; I $G(BLRRL("BILL TYPE"))="" I "CTP"[$G(BLRBT) S BLRRL("BILL TYPE")=BLRBT,BLRINS=1 S BT=$$BTP(OR,BTP) Q
+3 ; IHS/MSC/MKK - LR*5.2*1034
IF $GET(BLRRL("BILL TYPE"))=""
IF $LENGTH($GET(BLRBT))
IF "CTP"[$GET(BLRBT)
SET BLRRL("BILL TYPE")=BLRBT
SET BLRINS=1
SET BT=$$BTP(OR,BTP)
QUIT
+4 IF $GET(BLRRL("BILL TYPE"))=""
SET BLRRL("BILL TYPE")=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
+5 IF $GET(BLRRL("BILL TYPE"))'=""
SET BLRINS=1
End DoDot:1
QUIT
+6 IF $GET(BLRGUI)
QUIT
+7 NEW BT,ORI
+8 IF '$GET(CDT)
SET CDT=$PIECE($GET(^BLRRLO($ORDER(^BLRRLO("B",OR,0)),0)),U,6)
+9 IF '$GET(CDT)
SET CDT=DT
+10 IF BTP'="T"
Begin DoDot:1
+11 SET BT=$$BTP(OR,BTP)
End DoDot:1
QUIT
+12 ; Clear DIR array and special FileMan variables - IHS/MSC/MKK - LR*5.2*1034
KILL DIR,DIRUT,DTOUT,DUOUT
+13 SET DIR(0)="S^C:Client;T:Third Party;P:Patient"
+14 SET DIR("A")="Which Party is Responsible for Billing: "
+15 SET DIR("B")=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
+16 DO ^DIR
+17 ; If user exits or Times Out, reset Y variable - IHS/MSC/MKK - LR*5.2*1034
IF $DATA(DIRUT)
KILL Y
SET Y="C"
SET Y(0)="Client"
+18 SET BLRRL("BILL TYPE")=Y(0)
+19 SET BT=$$BTP(OR,$GET(Y))
+20 ;I $D(DIRUT) S BLRRL("BILL TYPE")="Client" ; Comment out line - IHS/MSC/MKK LR*5.2*1034
+21 KILL DIR
+22 IF $EXTRACT(BLRRL("BILL TYPE"),1,1)="T"
Begin DoDot:1
+23 SET ORI=$ORDER(^BLRRLO("B",OR,0))
+24 IF $ORDER(^BLRRLO(ORI,1,"B",0))
SET BLRDXS=1
+25 DO INS(OR,AC,DFN,CDT,0)
End DoDot:1
+26 IF $EXTRACT(BLRRL("BILL TYPE"),1,1)="T"
IF '$GET(BLRDXS)
WRITE !,"You must select an ICD Diagnosis if Bill Type is Third Party"
DO DX(OR)
+27 IF $EXTRACT(BLRRL("BILL TYPE"),1,1)="T"
IF '$GET(BLRINSS)
WRITE !,"You must select an Insurer if Bill Type is Third Party"
DO BILL(BTP,OR,AC)
+28 SET BLRINS=1
+29 QUIT
+30 ;
INS(OR,AC,PAT,CD,ED) ;-- lets get a list of selectable insurances for the patient and if set for auto select pick the first one in sequence
+1 ;we must also setup the BLRRL insurance array and diagnosis array for GIS
+2 NEW INSS,BT,BDA,BDAC,BLRRLDA,BLRNUM
+3 ;ihs/cmi/maw 07/24/2013 patch 1033
KILL AGINS,AGINSNN,AGINSN
+4 SET BDAC=0
+5 SET DFN=PAT
+6 DO ^AGINS
+7 IF '$DATA(AGINS(1))
IF $EXTRACT($GET(BLRRL("BILL TYPE")),1,1)="T"
Begin DoDot:1
+8 WRITE !,"Patient has No Insurance on file, changing Bill Type to Client"
+9 SET BT=$$BTP(OR,"C")
End DoDot:1
QUIT
+10 ;get flag for insurance
IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,21)
Begin DoDot:1
+11 WRITE !,"Now applying Sequenced Insurer to Accession"
+12 IF '$GET(CD)
SET CD=DT
+13 DO SEQINS(.AGINS,PAT,CD)
+14 IF '$DATA(BLRSEQ(1))
Begin DoDot:2
+15 WRITE !,"Patient Insurance has not been Sequenced, changing Bill Type to Client"
+16 SET BT=$$BTP(OR,"C")
End DoDot:2
QUIT
+17 SET BDA=0
FOR
SET BDA=$ORDER(BLRSEQ(BDA))
IF 'BDA!(BDAC>3)
QUIT
Begin DoDot:2
+18 SET BDAC=BDAC+1
+19 ;have to switch to ~ for filing
SET INSS=$TRANSLATE($GET(BLRSEQ(BDA)),"^","~")
+20 DO UPINS(OR,AC,PAT,INSS)
End DoDot:2
End DoDot:1
QUIT
+21 SET BLRRLDA=0
FOR
SET BLRRLDA=$ORDER(AGINS(BLRRLDA))
IF 'BLRRLDA
QUIT
Begin DoDot:1
+22 SET BLRNUM=BLRRLDA
+23 WRITE !,BLRRLDA_")"_$PIECE(AGINS(BLRRLDA),U)_$SELECT($PIECE(AGINS(BLRRLDA),U,4)]"":"("_$EXTRACT($PIECE(AGINS(BLRRLDA),U,4),1,2)_")",1:"")
+24 WRITE ?30,"Policy #: "_$PIECE(AGINS(BLRRLDA),U,9)
+25 WRITE ?50,"Elg/Exp Date: "_$SELECT($PIECE(AGINS(BLRRLDA),U,5)>0:$$FMTE^XLFDT($PIECE(AGINS(BLRRLDA),U,5)),1:"")_"/"_$SELECT($PIECE(AGINS(BLRRLDA),U,6)>0:$$FMTE^XLFDT($PIECE(AGINS(BLRRLDA),U,6)),1:"")
End DoDot:1
+26 KILL DIR,DIRUT,DTOUT,DUOUT
+27 SET DIR(0)="N"_$SELECT(ED:"O",1:"")_"^1:"_+$GET(BLRNUM)
SET DIR("A")="Select the insurer for this accession: "
+28 DO ^DIR
+29 IF $DATA(DIRUT)
QUIT
+30 IF Y<0
QUIT
+31 SET BLRINS=+Y
+32 ;have to switch to ~ for filing
SET INSS=$TRANSLATE($GET(AGINS(BLRINS)),"^","~")
+33 DO UPINS(OR,AC,PAT,INSS)
+34 QUIT
+35 ;
UPINS(O,A,P,S) ;-- update the entry in the BLR REFERENCE LAB ORDER/ACCESSION file
+1 NEW FI,FDA,FIENS,FERR
+2 SET FI=$ORDER(^BLRRLO("B",O,0))
+3 IF '$GET(FI)
SET FI=$ORDER(^BLRRLO("ACC",A,0))
+4 SET FIENS=FI_","
+5 SET FDA(9009026.32,"+2,"_FIENS,.01)=S
+6 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+7 IF $DATA(FERR(1))
WRITE !,"Error adding insurance to Order "_OR_" in the Reference Lab Order file"
+8 SET BLRINSS=1
+9 QUIT
+10 ;
SEQINS(BINS,PT,RLCDT) ;-- lets go through sequencing insurers
+1 IF '$ORDER(BINS(""))
QUIT
+2 ;ihs/cmi/maw 10/07/2013 patch 1033
KILL BLRSEQ
+3 NEW BDA
+4 SET BDA=0
FOR
SET BDA=$ORDER(BINS(BDA))
IF 'BDA
QUIT
Begin DoDot:1
+5 NEW BINI,SEQ,POLI
+6 SET BINI=$PIECE(BINS(BDA),U,2)
+7 SET POLI=$PIECE(BINS(BDA),U,9)
+8 SET SEQ=$$FNDSEQ(BINI,PT,POLI,RLCDT)
+9 IF 'SEQ
QUIT
+10 SET BLRSEQ(SEQ)=$GET(BINS(BDA))
End DoDot:1
+11 QUIT
+12 ;
FNDSEQ(BN,PTI,POL,CDT) ;-- find the category prioritization
+1 NEW SQDA,EFF,SQPRI
+2 SET EFF=$ORDER(^AUPNICP("EFF",PTI,"M",""),-1)
+3 IF '$GET(EFF)
QUIT ""
+4 SET SQDA=0
FOR
SET SQDA=$ORDER(^AUPNICP("EFF",PTI,"M",EFF,SQDA))
IF 'SQDA!($GET(SQPRI))
QUIT
Begin DoDot:1
+5 NEW SQDATA,SQPAT,SQPOL,SQINS
+6 SET SQDATA=$GET(^AUPNICP(SQDA,0))
+7 SET SQPAT=$PIECE(SQDATA,U,2)
+8 SET SQINS=$PIECE(SQDATA,U,3)
+9 SET SQPOL=$PIECE(SQDATA,U,10)
+10 IF SQPAT'=PTI
QUIT
+11 IF SQINS'=BN
QUIT
+12 IF SQPOL'=POL
QUIT
+13 SET SQPRI=$PIECE(SQDATA,U,5)
End DoDot:1
+14 QUIT $GET(SQPRI)
+15 ;
EORD ;-- Edit the Order
+1 KILL DIC,DIE
+2 NEW DATA,ORD,ACC,PAT,CDT
+3 SET DIC(0)="AEMQZ"
+4 SET DIC("A")="Edit insurance/billing information for which order number: "
+5 SET DIC="^BLRRLO("
+6 DO ^DIC
+7 IF Y<0
QUIT
+8 SET DIE=DIC
+9 SET DA=+Y
+10 SET DR=".03;.05;1"
+11 DO ^DIE
+12 SET DATA=$GET(^BLRRLO(DA,0))
+13 SET ORD=$PIECE(DATA,U)
+14 SET ACC=$PIECE(DATA,U,2)
+15 SET PAT=$PIECE(DATA,U,4)
+16 SET CDT=$PIECE(DATA,U,6)
+17 DO COINS(DA)
+18 DO INS(ORD,ACC,PAT,CDT,1)
+19 DO EORD
+20 QUIT
+21 ;
COINS(IN) ;-- clean out insurances before reselecting
+1 NEW BDA
+2 SET DIK="^BLRRLO("_IN_",2,"
+3 SET DA(1)=IN
+4 SET BDA=0
FOR
SET BDA=$ORDER(^BLRRLO(IN,2,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+5 SET DA=BDA
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
