LRBEBA4 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**291,359,352,1031,1034**;NOV 1, 1997;Build 88
;
;
GPRO(LRBEDN,LRBECDT,LRBESPC,LRBETST) ; Get the Procedure (CPT)
; A qualified coder will setup the CPTs in #60. The routine look for
; CPTs by specimen, then HCPCS, and lasty, by a default.
;
S X="CH;"_LRBEDN_";1",Y=$O(^LAB(60,"C",X,0))
Q:+Y<0
S LRBETST=+Y
PANEL ;Entry point for panel cpt
N X,Y,DIC,LRBEIEN,LRBENLT,LRN
S:$G(LRSPEC)="" LRSPEC=$G(LRBESPC)
S (LRI,LRBECPT)=""
; #60 Specimen CPT
SP60 D GCPT(LRBETST,LRBECDT,LRSPEC) Q:$O(LRBECPT(LRBETST,0))
;HCPCS CODE
HCPCS D
. S LRBECPT=$$GET1^DIQ(60,LRBETST_",","HCPCS CODE","I")
. I LRBECPT D
. . S LRBECPT=$$CPT^ICPTCOD(LRBECPT,LRBECDT)
. . I '$P(LRBECPT,U,7) S LRBECPT="" Q
. . S LRBECPT(LRBETST,$G(LRI)+1,$P(LRBECPT,U))="HCPCS CODE",LRI=$G(LRI)+1
;Try file #64
NLT Q:$O(LRBECPT(LRBETST,0)) D
. N I,LRBENLT,LRX,LRN,LRNM,SUFX
. S LRBENLT=$$GET1^DIQ(60,LRBETST_",",64,"I")
. Q:'LRBENLT
. S LRNM=$P($G(^LAM(LRBENLT,0)),U,2)
. S LRNM(1)=LRNM
. S SUFX=$P(LRNM,".",2)
. I $G(LRCDEF),SUFX'=LRCDEF S LRNM(2)=$P(LRNM,".",1)_"."_LRCDEF
. I SUFX S LRNM(3)=$P(LRNM,".",1)_"."_"0000"
. S I=0 F S I=$O(LRNM(I)) Q:'I Q:$O(LRBECPT(LRBETST,0)) D
. . S LRBENLT=$O(^LAM("C",LRNM(I)_" ",0)) Q:'LRBENLT
. . S LRN=0 F S LRN=$O(^LAM(LRBENLT,4,"AC","CPT",LRN)) Q:LRN<1 D
. . . S LRX=$G(^LAM(LRBENLT,4,LRN,0)) Q:'LRX D
. . . . Q:'$P(LRX,U,3)!($P(LRX,U,3)>LRBECDT)!($P(LRX,U,4)&($P(LRX,U,4)<LRBECDT))
. . . . S LRBECPT=+LRX
. . . . I '$P($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7) Q
. . . . S LRBECPT(LRBETST,($G(LRI)+1),LRBECPT)="WKLD CODE-"_LRNM(I),LRI=$G(LRI)+1
. . . . I LRI>1,LRBECPT(LRBETST,LRI,LRBECPT)=$G(LRBECPT(LRBETST,($G(LRI)-1),LRBECPT)) D
. . . . . S LRBECPT(LRBETST,($G(LRI)-1),LRBECPT,"COUNT")=+$G(LRBECPT(LRBETST,($G(LRI)-1),LRBECPT,"COUNT"))+1
. . . . . K LRBECPT(LRBETST,LRI,LRBECPT) S LRI=$G(LRI)-1
;Default Site/Spec CPT
SPCPT Q:$O(LRBECPT(LRBETST,0)) D
. S LRBECPT=$$GET1^DIQ(60,LRBETST_",","DEFAULT SITE/SPECIMEN CPT","E")
. I LRBECPT D
. . I '$P($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7) S LRBECPT="" Q
. . S LRBECPT(LRBETST,$G(LRI)+1,LRBECPT)="DEFAULT SITE/SPECIMEN CPT",LRI=$G(LRI)+1
Q
;
SCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
Q $$CPT^ICPTCOD(CPT,TDAT)
;
GCPT(LRBETST,LRBECDT,LRSPEC) ; Get the CPT
N A,ARR,LRBEAX,LRBEIEN,LRBEAR60,X,XX
S LRBEIEN=LRSPEC_","_LRBETST_",",(LRI,LRBECPT)=""
D GETS^DIQ(60.01,LRBEIEN,"96*","I","LRBEAR60")
S A="" F S A=$O(LRBEAR60(60.196,A)) Q:A="" D
. Q:$G(LRBEAR60(60.196,A,1,"I"))=""
. S ARR($G(LRBEAR60(60.196,A,1,"I")))=$G(LRBEAR60(60.196,A,.01,"I"))
S XX=$P(LRBECDT,".",1)_"."_9999
S X=$O(ARR(XX),-1) I X D
.S LRBEAX=ARR(X)
.S LRBEAX=$$CPT^ICPTCOD(LRBEAX,LRBECDT)
.Q:'$P(LRBEAX,U,7)
.S LRBECPT(LRBETST,($G(LRI)+1),$P(LRBEAX,U))="SPECIMEN CPT",LRI=$G(LRI)+1
Q
;
UPDOR(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ; Update CIDC information from OERR
I $G(^XTMP("LRPCELOG",0)) D
. N LRLNOW,LRI
. F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",3,LRLNOW))
. S ^XTMP("LRPCELOG",3,LRLNOW)=DFN_U_ORITEM_U_ORIEN_U_"["_ORSCEI_"]"
. S LRI=0 F S LRI=$O(ORDX(LRI)) Q:LRI="" D
. . S ^XTMP("LRPCELOG",3,LRLNOW,"ORDX",LRI)=ORDX(LRI)
I $S('$O(ORDX(0)):1,ORSCEI="^^^^^":1,1:0) Q "O^No Diagnosis Entered"
N LRBEAR,LRBEDFN,LRDFN,LRBEIEN,LRODT,LRORD,LRSN,LRBERMS,LRBETN,LRBETYP
N LRBEVST,LRAA,LRLLOC,LRSAMP,LRSPEC,LRSB,LRBEY
S LRBERMS=1,LRORD=$P(ORITEM,";",1),LRODT=$P(ORITEM,";",2)
S LRSN=$P(ORITEM,";",3),LRBEIEN=LRSN_","_LRODT_","
S (LRBEDFN,LRDFN)=$$GET1^DIQ(69.01,LRBEIEN,.01,"I")
S LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
S LRLLOC=$$GET1^DIQ(69.01,LRBEIEN,8,"I")
S LRSPEC=$$GET1^DIQ(69.02,"1,"_LRBEIEN,.01,"I") S:LRSPEC="" LRSPEC=72
I LRORD'=$$GET1^DIQ(69.01,LRBEIEN,9.5,"I") D Q LRBERMS
.S LRBERMS="0^"_$$EMSG(1)
I DFN'=$$GET1^DIQ(63,LRBEDFN_",",.03,"I") D Q LRBERMS
.S LRBERMS="0^"_$$EMSG(2)
S LRBEVST=$P($G(^LRO(69,LRODT,1,LRSN,"PCE")),";",1) D WORK
Q LRBERMS
;
WORK ; Enter the updated information into file
N LRBEFND,LRBETNM,LRBETST,LRBEZ,LRBERES
S (LRBETN,LRBEFND)=0
F S LRBETN=$O(^LRO(69,LRODT,1,LRSN,2,LRBETN)) Q:LRBETN=""!('LRBETN) D
.Q:ORIEN'=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,6,"I")
.S:'LRBEFND LRBEFND=1 S LRAA=""
.S LRBETST=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,.01,"I")
.S LRBETNM=$$GET1^DIQ(60,LRBETST_",",.01,"I")
.S LRBEZ(LRBETN)=LRBETST_"^"_LRBETNM K LRBEAR
.D BLRSB(.LRSB,LRBETN_","_LRBEIEN,LRBETST,.LRBEY)
.D KILL(LRODT,LRSN,LRBETN),SET(DFN,.ORDX,ORSCEI)
.D SDG1(LRODT,LRSN,LRBETN,DFN,.LRBEAR)
I 'LRBEFND S LRBERMS="0^"_$$EMSG(3) Q
I LRBEVST'="",LRAA'="" S LRBERES=1 D BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBEZ,"",LRBEVST,"",ORIEN)
Q
;
KILL(LRBEODT,LRBESN,LRBETN) ; Kill the existing DGX and SC/EI
N DA,DIK
S DA(1)=LRBETN,DA(2)=LRSN,DA(3)=LRODT
S DA="" F S DA=$O(^LRO(69,DA(3),1,DA(2),2,DA(1),2,DA)) Q:DA="" D
.S DIK="^LRO(69,"_DA(3)_","_1_","_DA(2)_","_2_","_DA(1)_","_2_","
.D ^DIK
Q
;
SET(DFN,ORDX,ORSCEI) ; Set #69 with new DGX and SC/EI
N LRBEA
S LRBEA="" F S LRBEA=$O(ORDX(LRBEA)) Q:LRBEA="" D
.S LRBEAR(DFN,"LRBEDGX",LRBEA,$G(ORDX(LRBEA)))="^^^"_ORSCEI
.S:LRBEA=1 $P(LRBEAR(DFN,"LRBEDGX",LRBEA,$G(ORDX(LRBEA))),U,12)=1
Q
;
SDG1(LRODT,LRSN,LRBETN,DFN,LRBEAR) ; Set the diagnois
; and indicators file #69
N LRBEA,LRBEFIL,LRBEIEN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM
S LRBEFIL=69.05,LRBETNUM=$O(^LRO(69,LRODT,1,LRSN,2,LRBETN,2,""),-1)+1
S LRBEA="" F S LRBEA=$O(LRBEAR(DFN,"LRBEDGX",LRBEA)) Q:LRBEA="" D
.S LRBEPDGX=""
.F S LRBEPDGX=$O(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX)) Q:LRBEPDGX="" D
..S LRBEPTDT=$G(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX))
..S LRBEIEN="+"_LRBETNUM_","_LRBETN_","_LRSN_","_LRODT_","
..S LRFDAIEN(LRBETNUM)=LRBETNUM,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
D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
Q
;
EMSG(LRBETYP) ; Return Error Message
N LRBEEMS,LRBETYPN
S:LRBETYP=1 LRBETYPN="Order Number" S:LRBETYP=2 LRBETYPN="DFN"
S:LRBETYP=3 LRBETYPN="Orderable Item"
S LRBEEMS="Possible reasons for failure is the "_LRBETYPN_" did not match."
Q LRBEEMS
;
BLRSB(LRSB,LRBEIENT,LRBETST,LRBEY) ; Build the LRSB global
N LRBESS,LRBEIDT,LRBESB,LRBEAA,LRBEAD,LRBEAN,LRBEIEN2,LRBET,NX,XX
S (LRAD,LRBEAD)=$$GET1^DIQ(69.03,LRBEIENT,2,"I")
S (LRAA,LRBEAA)=$$GET1^DIQ(69.03,LRBEIENT,3,"I") Q:LRAA=""
S (LRAN,LRBEAN)=$$GET1^DIQ(69.03,LRBEIENT,4,"I")
S LRBEIEN2=LRBEAN_","_LRBEAD_","_LRBEAA_","
S (LRSS,LRBESS)=$$GET1^DIQ(68,LRBEAA_",",.02,"I")
S (LRIDT,LRBEIDT)=$$GET1^DIQ(68.02,LRBEIEN2,13.5,"I")
S XX=$P($P(^LAB(60,LRBETST,0),U,5),";",2) I XX D
.S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
.I LRSB(XX)="" K LRSB(XX) Q
.I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
.S LRBEY(LRBETST,XX)=""
S NX=0 F S NX=$O(^LAB(60,LRBETST,2,NX)) Q:'NX D
.S LRBET=+^LAB(60,LRBETST,2,NX,0)
.S XX=$P($P(^LAB(60,LRBET,0),U,5),";",2) I XX D
..S LRSB(XX)=$G(^LR(LRDFN,LRSS,LRIDT,XX))
..I LRSB(XX)="" K LRSB(XX) Q
..I "pending^canc"[$P(LRSB(XX),U,1) K LRSB(XX) Q
..S LRBEY(LRBETST,XX)=""
Q
;
CHKINP(LRDFN,LRBEDAT) ; Check for Inpatient Status)
N VAIN,VAINDT
I '$G(DFN) D
. S DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
. S LRDPF=$$GET1^DIQ(63,LRDFN_",",.02,"I")
I $G(LRDPF)'=2 Q 0
S VAINDT=LRBEDAT D INP^VADPT
Q $G(VAIN(1))
;
RFLX() ; Ask the Reflex Question
Q 0 ; IHS/MSC/MKK - LR*5.2*1034 -- IHS Federal Task Leads don't want the question asked. Return No (0).
;
N DIR,DUOUT,DTOUT,DIRUT,Y
S DIR("A")="Is this a Reflex Test? (Y/N): "
S DIR(0)="YA" D ^DIR
I $D(DIRUT)!($D(DUOUT)!$D(DTOUT)) Q -1
Q +Y
;
DEFAULT ;Set Default diagnosis
N LRD,LRI,LRX,LRY,LRD
S (LRBEDMSG,LRDBEDGX)=""
S LRI=$O(^LRO(69,LRODT,1,LRSN,2,1,2,0)) Q:LRI<1
S LRD=$G(^LRO(69,LRODT,1,LRSN,2,1,2,LRI,0))
Q:'LRD
S LRDBEDGX=+LRD
S LRBEDMSG=+LRD_"^^^"_$P(LRD,U,4)_U_$P(LRD,U,5)_U_$P(LRD,U,2)
S LRBEDMSG=LRBEDMSG_U_$P(LRD,U,6)_U_$P(LRD,U,7)_U_$P(LRD,U,8)
S LRBEDMSG=LRBEDMSG_U_$P(LRD,U,3)_U_$P(LRD,U,10)_U_$P(LRD,U,9)
W:$G(LRDBUG) !,LRBEDMSG
Q
;
GEPRO(LRBEAA) ; Provider - Responsible Official
N X,LRBEPRO
S LRBEPRO=$$GET1^DIQ(68,LRBEAA_",",.1,"I")
I $$GET^XUA4A72(LRBEPRO,DT)<0 S LRBEPRO=$$GET1^DIQ(69.9,1,617,"I")
Q LRBEPRO
;
GOPRO(LRODT,LRSN) ; Get the Ordering Provider
N X,Y,DIC,LRBEPRO
S LRBEPRO=$$GET1^DIQ(69.01,LRSN_","_LRODT_",",7,"I")
I $$GET^XUA4A72(LRBEPRO,DT)<0 S LRBEPRO=0 D
.S X=$$GET1^DIQ(69.9,1,617,"I")
.I $$GET^XUA4A72(X,DT)>0 S LRBEPRO=X
Q LRBEPRO
LRBEBA4 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**291,359,352,1031,1034**;NOV 1, 1997;Build 88
+2 ;
+3 ;
GPRO(LRBEDN,LRBECDT,LRBESPC,LRBETST) ; Get the Procedure (CPT)
+1 ; A qualified coder will setup the CPTs in #60. The routine look for
+2 ; CPTs by specimen, then HCPCS, and lasty, by a default.
+3 ;
+4 SET X="CH;"_LRBEDN_";1"
SET Y=$ORDER(^LAB(60,"C",X,0))
+5 IF +Y<0
QUIT
+6 SET LRBETST=+Y
PANEL ;Entry point for panel cpt
+1 NEW X,Y,DIC,LRBEIEN,LRBENLT,LRN
+2 IF $GET(LRSPEC)=""
SET LRSPEC=$GET(LRBESPC)
+3 SET (LRI,LRBECPT)=""
+4 ; #60 Specimen CPT
SP60 DO GCPT(LRBETST,LRBECDT,LRSPEC)
IF $ORDER(LRBECPT(LRBETST,0))
QUIT
+1 ;HCPCS CODE
HCPCS Begin DoDot:1
+1 SET LRBECPT=$$GET1^DIQ(60,LRBETST_",","HCPCS CODE","I")
+2 IF LRBECPT
Begin DoDot:2
+3 SET LRBECPT=$$CPT^ICPTCOD(LRBECPT,LRBECDT)
+4 IF '$PIECE(LRBECPT,U,7)
SET LRBECPT=""
QUIT
+5 SET LRBECPT(LRBETST,$GET(LRI)+1,$PIECE(LRBECPT,U))="HCPCS CODE"
SET LRI=$GET(LRI)+1
End DoDot:2
End DoDot:1
+6 ;Try file #64
NLT IF $ORDER(LRBECPT(LRBETST,0))
QUIT
Begin DoDot:1
+1 NEW I,LRBENLT,LRX,LRN,LRNM,SUFX
+2 SET LRBENLT=$$GET1^DIQ(60,LRBETST_",",64,"I")
+3 IF 'LRBENLT
QUIT
+4 SET LRNM=$PIECE($GET(^LAM(LRBENLT,0)),U,2)
+5 SET LRNM(1)=LRNM
+6 SET SUFX=$PIECE(LRNM,".",2)
+7 IF $GET(LRCDEF)
IF SUFX'=LRCDEF
SET LRNM(2)=$PIECE(LRNM,".",1)_"."_LRCDEF
+8 IF SUFX
SET LRNM(3)=$PIECE(LRNM,".",1)_"."_"0000"
+9 SET I=0
FOR
SET I=$ORDER(LRNM(I))
IF 'I
QUIT
IF $ORDER(LRBECPT(LRBETST,0))
QUIT
Begin DoDot:2
+10 SET LRBENLT=$ORDER(^LAM("C",LRNM(I)_" ",0))
IF 'LRBENLT
QUIT
+11 SET LRN=0
FOR
SET LRN=$ORDER(^LAM(LRBENLT,4,"AC","CPT",LRN))
IF LRN<1
QUIT
Begin DoDot:3
+12 SET LRX=$GET(^LAM(LRBENLT,4,LRN,0))
IF 'LRX
QUIT
Begin DoDot:4
+13 IF '$PIECE(LRX,U,3)!($PIECE(LRX,U,3)>LRBECDT)!($PIECE(LRX,U,4)&($PIECE(LRX,U,4)<LRBECDT))
QUIT
+14 SET LRBECPT=+LRX
+15 IF '$PIECE($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7)
QUIT
+16 SET LRBECPT(LRBETST,($GET(LRI)+1),LRBECPT)="WKLD CODE-"_LRNM(I)
SET LRI=$GET(LRI)+1
+17 IF LRI>1
IF LRBECPT(LRBETST,LRI,LRBECPT)=$GET(LRBECPT(LRBETST,($GET(LRI)-1),LRBECPT))
Begin DoDot:5
+18 SET LRBECPT(LRBETST,($GET(LRI)-1),LRBECPT,"COUNT")=+$GET(LRBECPT(LRBETST,($GET(LRI)-1),LRBECPT,"COUNT"))+1
+19 KILL LRBECPT(LRBETST,LRI,LRBECPT)
SET LRI=$GET(LRI)-1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;Default Site/Spec CPT
SPCPT IF $ORDER(LRBECPT(LRBETST,0))
QUIT
Begin DoDot:1
+1 SET LRBECPT=$$GET1^DIQ(60,LRBETST_",","DEFAULT SITE/SPECIMEN CPT","E")
+2 IF LRBECPT
Begin DoDot:2
+3 IF '$PIECE($$CPT^ICPTCOD(LRBECPT,LRBECDT),U,7)
SET LRBECPT=""
QUIT
+4 SET LRBECPT(LRBETST,$GET(LRI)+1,LRBECPT)="DEFAULT SITE/SPECIMEN CPT"
SET LRI=$GET(LRI)+1
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
SCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
+1 QUIT $$CPT^ICPTCOD(CPT,TDAT)
+2 ;
GCPT(LRBETST,LRBECDT,LRSPEC) ; Get the CPT
+1 NEW A,ARR,LRBEAX,LRBEIEN,LRBEAR60,X,XX
+2 SET LRBEIEN=LRSPEC_","_LRBETST_","
SET (LRI,LRBECPT)=""
+3 DO GETS^DIQ(60.01,LRBEIEN,"96*","I","LRBEAR60")
+4 SET A=""
FOR
SET A=$ORDER(LRBEAR60(60.196,A))
IF A=""
QUIT
Begin DoDot:1
+5 IF $GET(LRBEAR60(60.196,A,1,"I"))=""
QUIT
+6 SET ARR($GET(LRBEAR60(60.196,A,1,"I")))=$GET(LRBEAR60(60.196,A,.01,"I"))
End DoDot:1
+7 SET XX=$PIECE(LRBECDT,".",1)_"."_9999
+8 SET X=$ORDER(ARR(XX),-1)
IF X
Begin DoDot:1
+9 SET LRBEAX=ARR(X)
+10 SET LRBEAX=$$CPT^ICPTCOD(LRBEAX,LRBECDT)
+11 IF '$PIECE(LRBEAX,U,7)
QUIT
+12 SET LRBECPT(LRBETST,($GET(LRI)+1),$PIECE(LRBEAX,U))="SPECIMEN CPT"
SET LRI=$GET(LRI)+1
End DoDot:1
+13 QUIT
+14 ;
UPDOR(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ; Update CIDC information from OERR
+1 IF $GET(^XTMP("LRPCELOG",0))
Begin DoDot:1
+2 NEW LRLNOW,LRI
+3 FOR
SET LRLNOW=$$NOW^XLFDT
IF '$DATA(^XTMP("LRPCELOG",3,LRLNOW))
QUIT
+4 SET ^XTMP("LRPCELOG",3,LRLNOW)=DFN_U_ORITEM_U_ORIEN_U_"["_ORSCEI_"]"
+5 SET LRI=0
FOR
SET LRI=$ORDER(ORDX(LRI))
IF LRI=""
QUIT
Begin DoDot:2
+6 SET ^XTMP("LRPCELOG",3,LRLNOW,"ORDX",LRI)=ORDX(LRI)
End DoDot:2
End DoDot:1
+7 IF $SELECT('$ORDER(ORDX(0)):1,ORSCEI="^^^^^":1,1:0)
QUIT "O^No Diagnosis Entered"
+8 NEW LRBEAR,LRBEDFN,LRDFN,LRBEIEN,LRODT,LRORD,LRSN,LRBERMS,LRBETN,LRBETYP
+9 NEW LRBEVST,LRAA,LRLLOC,LRSAMP,LRSPEC,LRSB,LRBEY
+10 SET LRBERMS=1
SET LRORD=$PIECE(ORITEM,";",1)
SET LRODT=$PIECE(ORITEM,";",2)
+11 SET LRSN=$PIECE(ORITEM,";",3)
SET LRBEIEN=LRSN_","_LRODT_","
+12 SET (LRBEDFN,LRDFN)=$$GET1^DIQ(69.01,LRBEIEN,.01,"I")
+13 SET LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
+14 SET LRLLOC=$$GET1^DIQ(69.01,LRBEIEN,8,"I")
+15 SET LRSPEC=$$GET1^DIQ(69.02,"1,"_LRBEIEN,.01,"I")
IF LRSPEC=""
SET LRSPEC=72
+16 IF LRORD'=$$GET1^DIQ(69.01,LRBEIEN,9.5,"I")
Begin DoDot:1
+17 SET LRBERMS="0^"_$$EMSG(1)
End DoDot:1
QUIT LRBERMS
+18 IF DFN'=$$GET1^DIQ(63,LRBEDFN_",",.03,"I")
Begin DoDot:1
+19 SET LRBERMS="0^"_$$EMSG(2)
End DoDot:1
QUIT LRBERMS
+20 SET LRBEVST=$PIECE($GET(^LRO(69,LRODT,1,LRSN,"PCE")),";",1)
DO WORK
+21 QUIT LRBERMS
+22 ;
WORK ; Enter the updated information into file
+1 NEW LRBEFND,LRBETNM,LRBETST,LRBEZ,LRBERES
+2 SET (LRBETN,LRBEFND)=0
+3 FOR
SET LRBETN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRBETN))
IF LRBETN=""!('LRBETN)
QUIT
Begin DoDot:1
+4 IF ORIEN'=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,6,"I")
QUIT
+5 IF 'LRBEFND
SET LRBEFND=1
SET LRAA=""
+6 SET LRBETST=$$GET1^DIQ(69.03,LRBETN_","_LRBEIEN,.01,"I")
+7 SET LRBETNM=$$GET1^DIQ(60,LRBETST_",",.01,"I")
+8 SET LRBEZ(LRBETN)=LRBETST_"^"_LRBETNM
KILL LRBEAR
+9 DO BLRSB(.LRSB,LRBETN_","_LRBEIEN,LRBETST,.LRBEY)
+10 DO KILL(LRODT,LRSN,LRBETN)
DO SET(DFN,.ORDX,ORSCEI)
+11 DO SDG1(LRODT,LRSN,LRBETN,DFN,.LRBEAR)
End DoDot:1
+12 IF 'LRBEFND
SET LRBERMS="0^"_$$EMSG(3)
QUIT
+13 IF LRBEVST'=""
IF LRAA'=""
SET LRBERES=1
DO BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBEZ,"",LRBEVST,"",ORIEN)
+14 QUIT
+15 ;
KILL(LRBEODT,LRBESN,LRBETN) ; Kill the existing DGX and SC/EI
+1 NEW DA,DIK
+2 SET DA(1)=LRBETN
SET DA(2)=LRSN
SET DA(3)=LRODT
+3 SET DA=""
FOR
SET DA=$ORDER(^LRO(69,DA(3),1,DA(2),2,DA(1),2,DA))
IF DA=""
QUIT
Begin DoDot:1
+4 SET DIK="^LRO(69,"_DA(3)_","_1_","_DA(2)_","_2_","_DA(1)_","_2_","
+5 DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
SET(DFN,ORDX,ORSCEI) ; Set #69 with new DGX and SC/EI
+1 NEW LRBEA
+2 SET LRBEA=""
FOR
SET LRBEA=$ORDER(ORDX(LRBEA))
IF LRBEA=""
QUIT
Begin DoDot:1
+3 SET LRBEAR(DFN,"LRBEDGX",LRBEA,$GET(ORDX(LRBEA)))="^^^"_ORSCEI
+4 IF LRBEA=1
SET $PIECE(LRBEAR(DFN,"LRBEDGX",LRBEA,$GET(ORDX(LRBEA))),U,12)=1
End DoDot:1
+5 QUIT
+6 ;
SDG1(LRODT,LRSN,LRBETN,DFN,LRBEAR) ; Set the diagnois
+1 ; and indicators file #69
+2 NEW LRBEA,LRBEFIL,LRBEIEN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM
+3 SET LRBEFIL=69.05
SET LRBETNUM=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRBETN,2,""),-1)+1
+4 SET LRBEA=""
FOR
SET LRBEA=$ORDER(LRBEAR(DFN,"LRBEDGX",LRBEA))
IF LRBEA=""
QUIT
Begin DoDot:1
+5 SET LRBEPDGX=""
+6 FOR
SET LRBEPDGX=$ORDER(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX))
IF LRBEPDGX=""
QUIT
Begin DoDot:2
+7 SET LRBEPTDT=$GET(LRBEAR(DFN,"LRBEDGX",LRBEA,LRBEPDGX))
+8 SET LRBEIEN="+"_LRBETNUM_","_LRBETN_","_LRSN_","_LRODT_","
+9 SET LRFDAIEN(LRBETNUM)=LRBETNUM
SET LRFDA(99,LRBEFIL,LRBEIEN,.01)=LRBEPDGX
+10 IF $PIECE(LRBEPTDT,U,6)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,1)=$PIECE(LRBEPTDT,U,6)
+11 IF $PIECE(LRBEPTDT,U,10)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,2)=$PIECE(LRBEPTDT,U,10)
+12 IF $PIECE(LRBEPTDT,U,4)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,3)=$PIECE(LRBEPTDT,U,4)
+13 IF $PIECE(LRBEPTDT,U,5)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,4)=$PIECE(LRBEPTDT,U,5)
+14 IF $PIECE(LRBEPTDT,U,7)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,5)=$PIECE(LRBEPTDT,U,7)
+15 IF $PIECE(LRBEPTDT,U,8)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,6)=$PIECE(LRBEPTDT,U,8)
+16 IF $PIECE(LRBEPTDT,U,9)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,7)=$PIECE(LRBEPTDT,U,9)
+17 IF $PIECE(LRBEPTDT,U,11)'=""
SET LRFDA(99,LRBEFIL,LRBEIEN,9)=$PIECE(LRBEPTDT,U,11)
+18 ;Is Primary?
IF $PIECE(LRBEPTDT,U,12)=1
SET LRFDA(99,LRBEFIL,LRBEIEN,8)=1
+19 SET LRBETNUM=LRBETNUM+1
End DoDot:2
End DoDot:1
+20 DO UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
+21 QUIT
+22 ;
EMSG(LRBETYP) ; Return Error Message
+1 NEW LRBEEMS,LRBETYPN
+2 IF LRBETYP=1
SET LRBETYPN="Order Number"
IF LRBETYP=2
SET LRBETYPN="DFN"
+3 IF LRBETYP=3
SET LRBETYPN="Orderable Item"
+4 SET LRBEEMS="Possible reasons for failure is the "_LRBETYPN_" did not match."
+5 QUIT LRBEEMS
+6 ;
BLRSB(LRSB,LRBEIENT,LRBETST,LRBEY) ; Build the LRSB global
+1 NEW LRBESS,LRBEIDT,LRBESB,LRBEAA,LRBEAD,LRBEAN,LRBEIEN2,LRBET,NX,XX
+2 SET (LRAD,LRBEAD)=$$GET1^DIQ(69.03,LRBEIENT,2,"I")
+3 SET (LRAA,LRBEAA)=$$GET1^DIQ(69.03,LRBEIENT,3,"I")
IF LRAA=""
QUIT
+4 SET (LRAN,LRBEAN)=$$GET1^DIQ(69.03,LRBEIENT,4,"I")
+5 SET LRBEIEN2=LRBEAN_","_LRBEAD_","_LRBEAA_","
+6 SET (LRSS,LRBESS)=$$GET1^DIQ(68,LRBEAA_",",.02,"I")
+7 SET (LRIDT,LRBEIDT)=$$GET1^DIQ(68.02,LRBEIEN2,13.5,"I")
+8 SET XX=$PIECE($PIECE(^LAB(60,LRBETST,0),U,5),";",2)
IF XX
Begin DoDot:1
+9 SET LRSB(XX)=$GET(^LR(LRDFN,LRSS,LRIDT,XX))
+10 IF LRSB(XX)=""
KILL LRSB(XX)
QUIT
+11 IF "pending^canc"[$PIECE(LRSB(XX),U,1)
KILL LRSB(XX)
QUIT
+12 SET LRBEY(LRBETST,XX)=""
End DoDot:1
+13 SET NX=0
FOR
SET NX=$ORDER(^LAB(60,LRBETST,2,NX))
IF 'NX
QUIT
Begin DoDot:1
+14 SET LRBET=+^LAB(60,LRBETST,2,NX,0)
+15 SET XX=$PIECE($PIECE(^LAB(60,LRBET,0),U,5),";",2)
IF XX
Begin DoDot:2
+16 SET LRSB(XX)=$GET(^LR(LRDFN,LRSS,LRIDT,XX))
+17 IF LRSB(XX)=""
KILL LRSB(XX)
QUIT
+18 IF "pending^canc"[$PIECE(LRSB(XX),U,1)
KILL LRSB(XX)
QUIT
+19 SET LRBEY(LRBETST,XX)=""
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
CHKINP(LRDFN,LRBEDAT) ; Check for Inpatient Status)
+1 NEW VAIN,VAINDT
+2 IF '$GET(DFN)
Begin DoDot:1
+3 SET DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
+4 SET LRDPF=$$GET1^DIQ(63,LRDFN_",",.02,"I")
End DoDot:1
+5 IF $GET(LRDPF)'=2
QUIT 0
+6 SET VAINDT=LRBEDAT
DO INP^VADPT
+7 QUIT $GET(VAIN(1))
+8 ;
RFLX() ; Ask the Reflex Question
+1 ; IHS/MSC/MKK - LR*5.2*1034 -- IHS Federal Task Leads don't want the question asked. Return No (0).
QUIT 0
+2 ;
+3 NEW DIR,DUOUT,DTOUT,DIRUT,Y
+4 SET DIR("A")="Is this a Reflex Test? (Y/N): "
+5 SET DIR(0)="YA"
DO ^DIR
+6 IF $DATA(DIRUT)!($DATA(DUOUT)!$DATA(DTOUT))
QUIT -1
+7 QUIT +Y
+8 ;
DEFAULT ;Set Default diagnosis
+1 NEW LRD,LRI,LRX,LRY,LRD
+2 SET (LRBEDMSG,LRDBEDGX)=""
+3 SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,1,2,0))
IF LRI<1
QUIT
+4 SET LRD=$GET(^LRO(69,LRODT,1,LRSN,2,1,2,LRI,0))
+5 IF 'LRD
QUIT
+6 SET LRDBEDGX=+LRD
+7 SET LRBEDMSG=+LRD_"^^^"_$PIECE(LRD,U,4)_U_$PIECE(LRD,U,5)_U_$PIECE(LRD,U,2)
+8 SET LRBEDMSG=LRBEDMSG_U_$PIECE(LRD,U,6)_U_$PIECE(LRD,U,7)_U_$PIECE(LRD,U,8)
+9 SET LRBEDMSG=LRBEDMSG_U_$PIECE(LRD,U,3)_U_$PIECE(LRD,U,10)_U_$PIECE(LRD,U,9)
+10 IF $GET(LRDBUG)
WRITE !,LRBEDMSG
+11 QUIT
+12 ;
GEPRO(LRBEAA) ; Provider - Responsible Official
+1 NEW X,LRBEPRO
+2 SET LRBEPRO=$$GET1^DIQ(68,LRBEAA_",",.1,"I")
+3 IF $$GET^XUA4A72(LRBEPRO,DT)<0
SET LRBEPRO=$$GET1^DIQ(69.9,1,617,"I")
+4 QUIT LRBEPRO
+5 ;
GOPRO(LRODT,LRSN) ; Get the Ordering Provider
+1 NEW X,Y,DIC,LRBEPRO
+2 SET LRBEPRO=$$GET1^DIQ(69.01,LRSN_","_LRODT_",",7,"I")
+3 IF $$GET^XUA4A72(LRBEPRO,DT)<0
SET LRBEPRO=0
Begin DoDot:1
+4 SET X=$$GET1^DIQ(69.9,1,617,"I")
+5 IF $$GET^XUA4A72(X,DT)>0
SET LRBEPRO=X
End DoDot:1
+6 QUIT LRBEPRO
