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