LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
;;5.2;LAB SERVICE;**291,359,352,315**;Sep 27, 1994;Build 25
;
DG1(LRBESTG) ; Set the DG1 segment into the ^TMP
N LRBEDGX,LRBETNUM
S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
S LRBETNUM=$G(LRBETNUM)+1
S LRBEDGX=$P($P(LRBESTG,"|",4),"^",1)
S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM)=LRBEDGX
Q
ZCL(LRBESTG) ; Set the ZCL segment into the ^TMP
N LRBEX,LRBETNUM,LRBEIND
S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
S LRBEX=$P(LRBESTG,"|",3),LRBEIND=$P(LRBESTG,"|",4)
S $P(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM),U,LRBEX+1)=LRBEIND
Q
;
SDGX69(J,LRBEIEN) ; Set the diagnosis into #69
N LRBEDGX,LRBEFIL,LRFDA,LRFDAIEN,LRBESEQ,LRBEPTDT,LRBEIEN2
S LRBESEQ="",LRBEFIL=69.05
F S LRBESEQ=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D
.S LRBEPTDT=$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ))
.S LRBEIEN2=LRBESEQ_","_LRBEIEN
.I '$D(^LRO(69,LRODT,1,LRSN,2,$P(LRBEIEN,",",1),2,"B",$P(LRBEPTDT,U,1))) S LRBEIEN2="+"_LRBEIEN2
.S LRFDA(99,LRBEFIL,LRBEIEN2,.01)=$P(LRBEPTDT,U,1),LRFDAIEN(LRBESEQ)=LRBESEQ
.S LRFDA(99,LRBEFIL,LRBEIEN2,1)=$P(LRBEPTDT,U,4) ;SC
.S LRFDA(99,LRBEFIL,LRBEIEN2,2)=$P(LRBEPTDT,U,8) ;CV
.S LRFDA(99,LRBEFIL,LRBEIEN2,3)=$P(LRBEPTDT,U,2) ;AO
.S LRFDA(99,LRBEFIL,LRBEIEN2,4)=$P(LRBEPTDT,U,3) ;IR
.S LRFDA(99,LRBEFIL,LRBEIEN2,5)=$P(LRBEPTDT,U,5) ;SWAC
.S LRFDA(99,LRBEFIL,LRBEIEN2,6)=$P(LRBEPTDT,U,6) ;MST
.S LRFDA(99,LRBEFIL,LRBEIEN2,7)=$P(LRBEPTDT,U,7) ;HNC
.S LRFDA(99,LRBEFIL,LRBEIEN2,9)=$P(LRBEPTDT,U,9) ;SHAD
.S:LRBESEQ=1 LRFDA(99,LRBEFIL,LRBEIEN2,8)=1 ;Is Primary?
D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
Q
;
GDG1(LRODT,SN,IFN) ; diagnosis and indicators back to CPRS
N LRBECNT,LRBEDGX,LRBESEQ,LRBEPTDT
S LRBECNT=2
S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ)) Q:LRBESEQ<1 D
.S LRBEPTDT=$G(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ,0))
.Q:'$G(LRBEPTDT)
.S:$P(LRBEPTDT,"^",9)=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",1)=LRBEPTDT
.S:$P(LRBEPTDT,"^",9)'=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBECNT)=LRBEPTDT,LRBECNT=LRBECNT+1
Q
;
SDG1(IFN,CTR,LRBEMSG) ; Setup the DG1 segment For CPRS
N LRBEX,LRBEDGX,LRBEIEN,LRBESEQ,LRBEPTDT,LRBEXMSG
S LRBESEQ="" F S LRBESEQ=$O(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D
.S LRBEPTDT=$G(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ))
.S LRBEDGX=$$GET1^DIQ(80,$P(LRBEPTDT,U,1)_",",.01,"I")
.S LRBEXMSG=$P($$ICDDX^ICDCODE($P(LRBEPTDT,U),,,1),U,4)
.S LRBEX=$P(LRBEPTDT,U,1)_"^"_LRBEXMSG_"^80^"_LRBEDGX_"^"_LRBEXMSG_"^ICD9"
.S CTR=CTR+1,@LRBEMSG@(CTR)="DG1|"_LRBESEQ_"||"_LRBEX_"|||||||||||||"
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|1|"_$P(LRBEPTDT,U,4)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|2|"_$P(LRBEPTDT,U,5)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|3|"_$P(LRBEPTDT,U,2)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|4|"_$P(LRBEPTDT,U,6)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|5|"_$P(LRBEPTDT,U,7)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|6|"_$P(LRBEPTDT,U,8)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|7|"_$P(LRBEPTDT,U,3)
.S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|8|"_$P(LRBEPTDT,U,10)
Q
;
GMOD(LRBEAA,LRBECPT) ; Get external service modifier
;input LRBECPT - ien to #81, not required
N LRBEMOD
S LRBECPT=$G(LRBECPT)
S LRBEMOD=$$GMOD^LRBEBA21(LRBEAA,LRBECPT)
Q LRBEMOD
;
SACC(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEX) ; Set Accession
N LRBEZ
D CARR(.LRBEX,.LRBEZ,LRSAMP,LRSPEC,LRTSTS)
D SDG1^LRBEBA(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEZ)
Q
;
CARR(LRBEAR,LRBEARR,LRBESAMP,LRBESPEC,LRTSTS) ; Change the array to only
; the specimen that needs to go
N LRBEDFN,LRBETS,LRBESMP,LRBESPC
M LRBEARR=LRBEAR
I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
S:$D(DFN) LRBEDFN=DFN
S LRBESMP=""
F S LRBESMP=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP="" D
.I LRBESAMP'=LRBESMP D Q
..K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)
.S LRBESPC=""
.F S LRBESPC=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC="" D
..I LRBESPEC'=LRBESPC D Q
...K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)
..S LRBETS=""
..F S LRBETS=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)) Q:LRBETS="" D
...I LRBETS'=LRTSTS K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)
Q
;
BLDAR(LRBEDFN,LRODT,LRSN,LRTN,LRBESMP,LRBESPC,LRBETST,LRBEAR) ; Build array
; with diagnosis and indicator info
K LRBEMSG,LRBESEQ,LRBEPTDT,LRBEODT,LRBEDMSG,LRDBEDGX,LRD
S LRBEODT=$P(LRODT,"."),LRBEPTDT=""
S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
Q:'$G(LRTN)
S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ)) Q:LRBESEQ<1 D
. I LRBESEQ,$D(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ,0)) S LRD=^(0) D
. . S LRBEMSG=+LRD_"^^^"_$P(LRD,U,4)_U_$P(LRD,U,5)_U_$P(LRD,U,2)
. . S LRBEMSG=LRBEMSG_U_$P(LRD,U,6)_U_$P(LRD,U,7)_U_$P(LRD,U,8)
. . S LRBEMSG=LRBEMSG_U_$P(LRD,U,3)_U_$P(LRD,U,10)_U_$P(LRD,U,9)
. . S LRBEDGX=+LRD
. S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)=LRBEMSG
;if test has no dx, sc/ei, then find default dx, sc/ei
S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,0)) I 'LRBESEQ D
. D DEFAULT^LRBEBA4 Q:$G(LRBENO)
. Q:'$G(LRDBEDGX)
. S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRDBEDGX)=LRBEDMSG
N LRTNX,LRI,LRTNXID
D BLDAR2(LRBETST,LRBETST,LRBESMP,LRBESPC)
S LRI=0 F S LRI=$O(^LAB(60,LRBETST,2,LRI)) Q:LRI<1 D
. S LRTNX=+$G(^LAB(60,LRBETST,2,LRI,0)) Q:'LRTNX
. S LRTNXID=$P($P(^LAB(60,LRTNX,0),U,5),";",2)
. I LRTNXID="" D BLDAR2(LRBETST,LRTNX,LRBESMP,LRBESPC)
Q
;
BLDAR2(LRBETST,XTEST,LRBESMP,LRBESPC) ;
N LRTNX,LRI,DGX,LRX
S LRI=0
F S LRI=$O(^LAB(60,XTEST,2,LRI)) Q:LRI<1 D
. S LRTNX=+$G(^LAB(60,XTEST,2,LRI,0)) Q:'LRTNX D
. . S DGX=0 F S DGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX)) Q:DGX<1 D
. . . S LRX=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX))
. . . Q:'LRX
. . . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRTNX,DGX)=LRX
Q
;
STDN(LRODT,LRBESN,LRBETEST,LRBEAR1) ; Test and Data Number
N LRBEA,LRBEB,LRBEC,LRBED,LRBEDX,LRBEPTDT,X,Y
S LRBEA="" F S LRBEA=$O(LRBETEST(LRBEA)) Q:LRBEA="" D
.S DIC="^LRO(69,"_LRODT_","_1_","_LRBESN_","_"2,",DIC(0)="MZ"
.S X=$P(LRBETEST(LRBEA),U,2) D ^DIC K DIC I +Y<1 Q
.S LRBEB=0 F S LRBEB=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB)) Q:LRBEB<1 D
..S LRBEC=0 F S LRBEC=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB,LRBEC)) Q:'LRBEC D
...S LRBED="" F S LRBED=$O(LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED)) Q:LRBED="" D
....S LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED,LRBEC)=LRBEB
Q
;
SOP(LRBEDFN,LRBESB,LRBEAR1,LRBEPAN,LRBEROLL) ;Outpatient Resulting
; Information in CIDC Array
N DIC,LRBEDN,LRBESTG,LRBEDGX,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRBETST
N LRBEPOS,LRORREFN,LRBE21
;LRBERES=Resend PCE date flag
K LRBECPT S (LRBECPT,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRORREFN)=""
S LRBEEPRO=$$GEPRO^LRBEBA4(LRAA),LRBEOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
S LRBETST=0 F S LRBETST=$O(LRBEAR1(LRBETST)) Q:'LRBETST D
. S LRBE21=0
. ;process AMA/billable panel CPT codes
. I $D(LRBEPAN(LRBETST)) D EN^LRBEBA21(.LRBE21)
. ;otherwise process atomic test(s) CPT codes
. I 'LRBE21 D
. . S LRY=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
. . Q:'LRY
. . S LRY=LRY_","_LRSN_","_LRODT_","
. . Q:$$GET1^DIQ(69.03,LRY,10,"I")
. . I $G(ORIEN),$$GET1^DIQ(69.03,LRY,6,"I")'=ORIEN Q
. . S LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
. . Q:'LRBECDT
. . S LRBEDN="" F S LRBEDN=$O(LRBEAR1(LRBETST,LRBEDN)) Q:LRBEDN="" D SOP2
. . I $D(LRBECPT)=11 S LRFDA(1,69.03,LRY,11)=1 D FILE^DIE("KS","LRFDA(1)","ERR")
Q
;
SOP2 ;Process atomic test CPT code
N OUT,LRBETSTX
I $G(LRBESB(LRBEDN))'="" D
. I $P(LRBESB(LRBEDN),U)="pending" Q
. I $P(LRBESB(LRBEDN),U)="canc" Q
. I '$G(LRBERES) Q:$P($G(LRBESB(LRBEDN)),U,13)
. S LRBEQTY=1
. D GPRO^LRBEBA4(LRBEDN,LRBECDT,LRSPEC,.LRBETSTX) I $G(LRBETSTX),$O(LRBECPT(LRBETSTX,0)) D
. . D GOREF^LRBEBA21(LRODT,LRSN,LRBEDN,.LRBEAR1,.LRORREFN)
. . S OUT=0 I $G(LRDFN),$G(LRIDT),$D(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN))) D
. . . ;test already sent to PCE
. . . I '$G(LRBERES) S OUT=$P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13) Q:OUT
. . . ;otherwise, mark it as sent to PCE
. . . S $P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13)=1
. . ;don't continue if test already sent to PCE and not re-sending from WORK^LRBEBA4
. . Q:OUT
. . S LRI=0 F S LRI=$O(LRBECPT(LRBETSTX,LRI)) Q:LRI<1 D
. . . S LRBECPT=$O(LRBECPT(LRBETSTX,LRI,0))
. . . S LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
. . . S LRBEPOS=$$GPOS(.LRBESB,LRBEDN)
. . . D GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
. . . S LRBESTG=LRBECPT_U_LRBEMOD_U_$G(LRBEDGX(LRBETST,1))_U_$G(LRBEDGX(LRBETST,2))_U_$G(LRBEDGX(LRBETST,3))
. . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
. . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,5))_U_$G(LRBEDGX(LRBETST,6))_U_$G(LRBEDGX(LRBETST,7))
. . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,8))_U_LRORREFN
. . . I $G(LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")) S $P(LRBESTG,U,20)=LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")+1
. . . S LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)=LRBESTG
Q
;
GPOS(LRBESB,LRBEDN) ; Get the Place of Service
Q $P($G(LRBESB(LRBEDN)),U,9)
;
SLROT(LRXST,LRTEST,LRBEOT) ;
D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBEBA2 9615 printed Nov 22, 2024@17:20:02 Page 2
LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
+1 ;;5.2;LAB SERVICE;**291,359,352,315**;Sep 27, 1994;Build 25
+2 ;
DG1(LRBESTG) ; Set the DG1 segment into the ^TMP
+1 NEW LRBEDGX,LRBETNUM
+2 SET LRBETNUM=$ORDER(^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
+3 SET LRBETNUM=$GET(LRBETNUM)+1
+4 SET LRBEDGX=$PIECE($PIECE(LRBESTG,"|",4),"^",1)
+5 SET ^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM)=LRBEDGX
+6 QUIT
ZCL(LRBESTG) ; Set the ZCL segment into the ^TMP
+1 NEW LRBEX,LRBETNUM,LRBEIND
+2 SET LRBETNUM=$ORDER(^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1)
+3 SET LRBEX=$PIECE(LRBESTG,"|",3)
SET LRBEIND=$PIECE(LRBESTG,"|",4)
+4 SET $PIECE(^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM),U,LRBEX+1)=LRBEIND
+5 QUIT
+6 ;
SDGX69(J,LRBEIEN) ; Set the diagnosis into #69
+1 NEW LRBEDGX,LRBEFIL,LRFDA,LRFDAIEN,LRBESEQ,LRBEPTDT,LRBEIEN2
+2 SET LRBESEQ=""
SET LRBEFIL=69.05
+3 FOR
SET LRBESEQ=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ))
if LRBESEQ=""
QUIT
Begin DoDot:1
+4 SET LRBEPTDT=$GET(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ))
+5 SET LRBEIEN2=LRBESEQ_","_LRBEIEN
+6 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,$PIECE(LRBEIEN,",",1),2,"B",$PIECE(LRBEPTDT,U,1)))
SET LRBEIEN2="+"_LRBEIEN2
+7 SET LRFDA(99,LRBEFIL,LRBEIEN2,.01)=$PIECE(LRBEPTDT,U,1)
SET LRFDAIEN(LRBESEQ)=LRBESEQ
+8 ;SC
SET LRFDA(99,LRBEFIL,LRBEIEN2,1)=$PIECE(LRBEPTDT,U,4)
+9 ;CV
SET LRFDA(99,LRBEFIL,LRBEIEN2,2)=$PIECE(LRBEPTDT,U,8)
+10 ;AO
SET LRFDA(99,LRBEFIL,LRBEIEN2,3)=$PIECE(LRBEPTDT,U,2)
+11 ;IR
SET LRFDA(99,LRBEFIL,LRBEIEN2,4)=$PIECE(LRBEPTDT,U,3)
+12 ;SWAC
SET LRFDA(99,LRBEFIL,LRBEIEN2,5)=$PIECE(LRBEPTDT,U,5)
+13 ;MST
SET LRFDA(99,LRBEFIL,LRBEIEN2,6)=$PIECE(LRBEPTDT,U,6)
+14 ;HNC
SET LRFDA(99,LRBEFIL,LRBEIEN2,7)=$PIECE(LRBEPTDT,U,7)
+15 ;SHAD
SET LRFDA(99,LRBEFIL,LRBEIEN2,9)=$PIECE(LRBEPTDT,U,9)
+16 ;Is Primary?
if LRBESEQ=1
SET LRFDA(99,LRBEFIL,LRBEIEN2,8)=1
End DoDot:1
+17 DO UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
+18 QUIT
+19 ;
GDG1(LRODT,SN,IFN) ; diagnosis and indicators back to CPRS
+1 NEW LRBECNT,LRBEDGX,LRBESEQ,LRBEPTDT
+2 SET LRBECNT=2
+3 SET LRBESEQ=0
FOR
SET LRBESEQ=$ORDER(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ))
if LRBESEQ<1
QUIT
Begin DoDot:1
+4 SET LRBEPTDT=$GET(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ,0))
+5 if '$GET(LRBEPTDT)
QUIT
+6 if $PIECE(LRBEPTDT,"^",9)=1
SET ^TMP("LRX",$JOB,69,IFN,"LRBEDGX",1)=LRBEPTDT
+7 if $PIECE(LRBEPTDT,"^",9)'=1
SET ^TMP("LRX",$JOB,69,IFN,"LRBEDGX",LRBECNT)=LRBEPTDT
SET LRBECNT=LRBECNT+1
End DoDot:1
+8 QUIT
+9 ;
SDG1(IFN,CTR,LRBEMSG) ; Setup the DG1 segment For CPRS
+1 NEW LRBEX,LRBEDGX,LRBEIEN,LRBESEQ,LRBEPTDT,LRBEXMSG
+2 SET LRBESEQ=""
FOR
SET LRBESEQ=$ORDER(^TMP("LRX",$JOB,69,IFN,"LRBEDGX",LRBESEQ))
if LRBESEQ=""
QUIT
Begin DoDot:1
+3 SET LRBEPTDT=$GET(^TMP("LRX",$JOB,69,IFN,"LRBEDGX",LRBESEQ))
+4 SET LRBEDGX=$$GET1^DIQ(80,$PIECE(LRBEPTDT,U,1)_",",.01,"I")
+5 SET LRBEXMSG=$PIECE($$ICDDX^ICDCODE($PIECE(LRBEPTDT,U),,,1),U,4)
+6 SET LRBEX=$PIECE(LRBEPTDT,U,1)_"^"_LRBEXMSG_"^80^"_LRBEDGX_"^"_LRBEXMSG_"^ICD9"
+7 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="DG1|"_LRBESEQ_"||"_LRBEX_"|||||||||||||"
+8 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|1|"_$PIECE(LRBEPTDT,U,4)
+9 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|2|"_$PIECE(LRBEPTDT,U,5)
+10 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|3|"_$PIECE(LRBEPTDT,U,2)
+11 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|4|"_$PIECE(LRBEPTDT,U,6)
+12 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|5|"_$PIECE(LRBEPTDT,U,7)
+13 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|6|"_$PIECE(LRBEPTDT,U,8)
+14 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|7|"_$PIECE(LRBEPTDT,U,3)
+15 SET CTR=CTR+1
SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|8|"_$PIECE(LRBEPTDT,U,10)
End DoDot:1
+16 QUIT
+17 ;
GMOD(LRBEAA,LRBECPT) ; Get external service modifier
+1 ;input LRBECPT - ien to #81, not required
+2 NEW LRBEMOD
+3 SET LRBECPT=$GET(LRBECPT)
+4 SET LRBEMOD=$$GMOD^LRBEBA21(LRBEAA,LRBECPT)
+5 QUIT LRBEMOD
+6 ;
SACC(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEX) ; Set Accession
+1 NEW LRBEZ
+2 DO CARR(.LRBEX,.LRBEZ,LRSAMP,LRSPEC,LRTSTS)
+3 DO SDG1^LRBEBA(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEZ)
+4 QUIT
+5 ;
CARR(LRBEAR,LRBEARR,LRBESAMP,LRBESPEC,LRTSTS) ; Change the array to only
+1 ; the specimen that needs to go
+2 NEW LRBEDFN,LRBETS,LRBESMP,LRBESPC
+3 MERGE LRBEARR=LRBEAR
+4 IF '$DATA(DFN)
SET LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+5 if $DATA(DFN)
SET LRBEDFN=DFN
+6 SET LRBESMP=""
+7 FOR
SET LRBESMP=$ORDER(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP))
if LRBESMP=""
QUIT
Begin DoDot:1
+8 IF LRBESAMP'=LRBESMP
Begin DoDot:2
+9 KILL LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)
End DoDot:2
QUIT
+10 SET LRBESPC=""
+11 FOR
SET LRBESPC=$ORDER(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC))
if LRBESPC=""
QUIT
Begin DoDot:2
+12 IF LRBESPEC'=LRBESPC
Begin DoDot:3
+13 KILL LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)
End DoDot:3
QUIT
+14 SET LRBETS=""
+15 FOR
SET LRBETS=$ORDER(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS))
if LRBETS=""
QUIT
Begin DoDot:3
+16 IF LRBETS'=LRTSTS
KILL LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
BLDAR(LRBEDFN,LRODT,LRSN,LRTN,LRBESMP,LRBESPC,LRBETST,LRBEAR) ; Build array
+1 ; with diagnosis and indicator info
+2 KILL LRBEMSG,LRBESEQ,LRBEPTDT,LRBEODT,LRBEDMSG,LRDBEDGX,LRD
+3 SET LRBEODT=$PIECE(LRODT,".")
SET LRBEPTDT=""
+4 SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
+5 if '$GET(LRTN)
QUIT
+6 SET LRBESEQ=0
FOR
SET LRBESEQ=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ))
if LRBESEQ<1
QUIT
Begin DoDot:1
+7 IF LRBESEQ
IF $DATA(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ,0))
SET LRD=^(0)
Begin DoDot:2
+8 SET LRBEMSG=+LRD_"^^^"_$PIECE(LRD,U,4)_U_$PIECE(LRD,U,5)_U_$PIECE(LRD,U,2)
+9 SET LRBEMSG=LRBEMSG_U_$PIECE(LRD,U,6)_U_$PIECE(LRD,U,7)_U_$PIECE(LRD,U,8)
+10 SET LRBEMSG=LRBEMSG_U_$PIECE(LRD,U,3)_U_$PIECE(LRD,U,10)_U_$PIECE(LRD,U,9)
+11 SET LRBEDGX=+LRD
End DoDot:2
+12 SET LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)=LRBEMSG
End DoDot:1
+13 ;if test has no dx, sc/ei, then find default dx, sc/ei
+14 SET LRBESEQ=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN,2,0))
IF 'LRBESEQ
Begin DoDot:1
+15 DO DEFAULT^LRBEBA4
if $GET(LRBENO)
QUIT
+16 if '$GET(LRDBEDGX)
QUIT
+17 SET LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRDBEDGX)=LRBEDMSG
End DoDot:1
+18 NEW LRTNX,LRI,LRTNXID
+19 DO BLDAR2(LRBETST,LRBETST,LRBESMP,LRBESPC)
+20 SET LRI=0
FOR
SET LRI=$ORDER(^LAB(60,LRBETST,2,LRI))
if LRI<1
QUIT
Begin DoDot:1
+21 SET LRTNX=+$GET(^LAB(60,LRBETST,2,LRI,0))
if 'LRTNX
QUIT
+22 SET LRTNXID=$PIECE($PIECE(^LAB(60,LRTNX,0),U,5),";",2)
+23 IF LRTNXID=""
DO BLDAR2(LRBETST,LRTNX,LRBESMP,LRBESPC)
End DoDot:1
+24 QUIT
+25 ;
BLDAR2(LRBETST,XTEST,LRBESMP,LRBESPC) ;
+1 NEW LRTNX,LRI,DGX,LRX
+2 SET LRI=0
+3 FOR
SET LRI=$ORDER(^LAB(60,XTEST,2,LRI))
if LRI<1
QUIT
Begin DoDot:1
+4 SET LRTNX=+$GET(^LAB(60,XTEST,2,LRI,0))
if 'LRTNX
QUIT
Begin DoDot:2
+5 SET DGX=0
FOR
SET DGX=$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX))
if DGX<1
QUIT
Begin DoDot:3
+6 SET LRX=$GET(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX))
+7 if 'LRX
QUIT
+8 SET LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRTNX,DGX)=LRX
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
STDN(LRODT,LRBESN,LRBETEST,LRBEAR1) ; Test and Data Number
+1 NEW LRBEA,LRBEB,LRBEC,LRBED,LRBEDX,LRBEPTDT,X,Y
+2 SET LRBEA=""
FOR
SET LRBEA=$ORDER(LRBETEST(LRBEA))
if LRBEA=""
QUIT
Begin DoDot:1
+3 SET DIC="^LRO(69,"_LRODT_","_1_","_LRBESN_","_"2,"
SET DIC(0)="MZ"
+4 SET X=$PIECE(LRBETEST(LRBEA),U,2)
DO ^DIC
KILL DIC
IF +Y<1
QUIT
+5 SET LRBEB=0
FOR
SET LRBEB=$ORDER(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB))
if LRBEB<1
QUIT
Begin DoDot:2
+6 SET LRBEC=0
FOR
SET LRBEC=$ORDER(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB,LRBEC))
if 'LRBEC
QUIT
Begin DoDot:3
+7 SET LRBED=""
FOR
SET LRBED=$ORDER(LRBEAR1($PIECE(LRBETEST(LRBEA),U,1),LRBED))
if LRBED=""
QUIT
Begin DoDot:4
+8 SET LRBEAR1($PIECE(LRBETEST(LRBEA),U,1),LRBED,LRBEC)=LRBEB
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
SOP(LRBEDFN,LRBESB,LRBEAR1,LRBEPAN,LRBEROLL) ;Outpatient Resulting
+1 ; Information in CIDC Array
+2 NEW DIC,LRBEDN,LRBESTG,LRBEDGX,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRBETST
+3 NEW LRBEPOS,LRORREFN,LRBE21
+4 ;LRBERES=Resend PCE date flag
+5 KILL LRBECPT
SET (LRBECPT,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRORREFN)=""
+6 SET LRBEEPRO=$$GEPRO^LRBEBA4(LRAA)
SET LRBEOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
+7 SET LRBETST=0
FOR
SET LRBETST=$ORDER(LRBEAR1(LRBETST))
if 'LRBETST
QUIT
Begin DoDot:1
+8 SET LRBE21=0
+9 ;process AMA/billable panel CPT codes
+10 IF $DATA(LRBEPAN(LRBETST))
DO EN^LRBEBA21(.LRBE21)
+11 ;otherwise process atomic test(s) CPT codes
+12 IF 'LRBE21
Begin DoDot:2
+13 SET LRY=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
+14 if 'LRY
QUIT
+15 SET LRY=LRY_","_LRSN_","_LRODT_","
+16 if $$GET1^DIQ(69.03,LRY,10,"I")
QUIT
+17 IF $GET(ORIEN)
IF $$GET1^DIQ(69.03,LRY,6,"I")'=ORIEN
QUIT
+18 SET LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
+19 if 'LRBECDT
QUIT
+20 SET LRBEDN=""
FOR
SET LRBEDN=$ORDER(LRBEAR1(LRBETST,LRBEDN))
if LRBEDN=""
QUIT
DO SOP2
+21 IF $DATA(LRBECPT)=11
SET LRFDA(1,69.03,LRY,11)=1
DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
SOP2 ;Process atomic test CPT code
+1 NEW OUT,LRBETSTX
+2 IF $GET(LRBESB(LRBEDN))'=""
Begin DoDot:1
+3 IF $PIECE(LRBESB(LRBEDN),U)="pending"
QUIT
+4 IF $PIECE(LRBESB(LRBEDN),U)="canc"
QUIT
+5 IF '$GET(LRBERES)
if $PIECE($GET(LRBESB(LRBEDN)),U,13)
QUIT
+6 SET LRBEQTY=1
+7 DO GPRO^LRBEBA4(LRBEDN,LRBECDT,LRSPEC,.LRBETSTX)
IF $GET(LRBETSTX)
IF $ORDER(LRBECPT(LRBETSTX,0))
Begin DoDot:2
+8 DO GOREF^LRBEBA21(LRODT,LRSN,LRBEDN,.LRBEAR1,.LRORREFN)
+9 SET OUT=0
IF $GET(LRDFN)
IF $GET(LRIDT)
IF $DATA(^LR(LRDFN,LRSS,LRIDT,$GET(LRBEDN)))
Begin DoDot:3
+10 ;test already sent to PCE
+11 IF '$GET(LRBERES)
SET OUT=$PIECE(^LR(LRDFN,LRSS,LRIDT,$GET(LRBEDN)),U,13)
if OUT
QUIT
+12 ;otherwise, mark it as sent to PCE
+13 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,$GET(LRBEDN)),U,13)=1
End DoDot:3
+14 ;don't continue if test already sent to PCE and not re-sending from WORK^LRBEBA4
+15 if OUT
QUIT
+16 SET LRI=0
FOR
SET LRI=$ORDER(LRBECPT(LRBETSTX,LRI))
if LRI<1
QUIT
Begin DoDot:3
+17 SET LRBECPT=$ORDER(LRBECPT(LRBETSTX,LRI,0))
+18 SET LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
+19 SET LRBEPOS=$$GPOS(.LRBESB,LRBEDN)
+20 DO GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
+21 SET LRBESTG=LRBECPT_U_LRBEMOD_U_$GET(LRBEDGX(LRBETST,1))_U_$GET(LRBEDGX(LRBETST,2))_U_$GET(LRBEDGX(LRBETST,3))
+22 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
+23 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,5))_U_$GET(LRBEDGX(LRBETST,6))_U_$GET(LRBEDGX(LRBETST,7))
+24 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,8))_U_LRORREFN
+25 IF $GET(LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT"))
SET $PIECE(LRBESTG,U,20)=LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")+1
+26 SET LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)=LRBESTG
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
GPOS(LRBESB,LRBEDN) ; Get the Place of Service
+1 QUIT $PIECE($GET(LRBESB(LRBEDN)),U,9)
+2 ;
SLROT(LRXST,LRTEST,LRBEOT) ;
+1 DO SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT)
+2 QUIT
