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

LRBEBA2.m

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