- LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**291,359,352,315,1031,1034**;NOV 1, 1997;Build 188
- ;
- 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 LRBEXMSG=$P($$ICDDX^ICDEX($P(LRBEPTDT,U),,,1),U,4) ; IHS/MSC/MKK - LR*5.2*1034
- .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
- Q:'$$MODEXIST^BLRUTIL4("EAS") ; IHS/MSC/MKK - LR*5.2*1031
- ;
- ; 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
- LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**291,359,352,315,1031,1034**;NOV 1, 1997;Build 188
- +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 ; S LRBEXMSG=$P($$ICDDX^ICDCODE($P(LRBEPTDT,U),,,1),U,4)
- +6 ; IHS/MSC/MKK - LR*5.2*1034
- SET LRBEXMSG=$PIECE($$ICDDX^ICDEX($PIECE(LRBEPTDT,U),,,1),U,4)
- +7 SET LRBEX=$PIECE(LRBEPTDT,U,1)_"^"_LRBEXMSG_"^80^"_LRBEDGX_"^"_LRBEXMSG_"^ICD9"
- +8 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="DG1|"_LRBESEQ_"||"_LRBEX_"|||||||||||||"
- +9 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|1|"_$PIECE(LRBEPTDT,U,4)
- +10 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|2|"_$PIECE(LRBEPTDT,U,5)
- +11 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|3|"_$PIECE(LRBEPTDT,U,2)
- +12 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|4|"_$PIECE(LRBEPTDT,U,6)
- +13 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|5|"_$PIECE(LRBEPTDT,U,7)
- +14 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|6|"_$PIECE(LRBEPTDT,U,8)
- +15 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|7|"_$PIECE(LRBEPTDT,U,3)
- +16 SET CTR=CTR+1
- SET @LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|8|"_$PIECE(LRBEPTDT,U,10)
- End DoDot:1
- +17 QUIT
- +18 ;
- 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 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$MODEXIST^BLRUTIL4("EAS")
- QUIT
- +2 ;
- +3 ; Information in CIDC Array
- +4 NEW DIC,LRBEDN,LRBESTG,LRBEDGX,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRBETST
- +5 NEW LRBEPOS,LRORREFN,LRBE21
- +6 ;LRBERES=Resend PCE date flag
- +7 KILL LRBECPT
- SET (LRBECPT,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRORREFN)=""
- +8 SET LRBEEPRO=$$GEPRO^LRBEBA4(LRAA)
- SET LRBEOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
- +9 SET LRBETST=0
- FOR
- SET LRBETST=$ORDER(LRBEAR1(LRBETST))
- IF 'LRBETST
- QUIT
- Begin DoDot:1
- +10 SET LRBE21=0
- +11 ;process AMA/billable panel CPT codes
- +12 IF $DATA(LRBEPAN(LRBETST))
- DO EN^LRBEBA21(.LRBE21)
- +13 ;otherwise process atomic test(s) CPT codes
- +14 IF 'LRBE21
- Begin DoDot:2
- +15 SET LRY=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
- +16 IF 'LRY
- QUIT
- +17 SET LRY=LRY_","_LRSN_","_LRODT_","
- +18 IF $$GET1^DIQ(69.03,LRY,10,"I")
- QUIT
- +19 IF $GET(ORIEN)
- IF $$GET1^DIQ(69.03,LRY,6,"I")'=ORIEN
- QUIT
- +20 SET LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
- +21 IF 'LRBECDT
- QUIT
- +22 SET LRBEDN=""
- FOR
- SET LRBEDN=$ORDER(LRBEAR1(LRBETST,LRBEDN))
- IF LRBEDN=""
- QUIT
- DO SOP2
- +23 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
- +24 QUIT
- +25 ;
- 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