LRBEBA3 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;10/04/11
;;5.2;LAB SERVICE;**291,359,352,350**;Sep 27, 1994;Build 230
;
BLDAR(LRBEDFN,LRODT,LRSN,LRBEAR,LRBEY,LRBETEST,LRBEPAN,LRBEDEL) ; Build LRBEAR array with
; CIDC information
N LRBEODT,LRBEIEN,LRBETST,LRBETS,LRJ,N,NX,P,X,XX,REQX,OK
S LRBEAR(LRBEDFN,"DSS ID")=LROOS
S LRBEAR(LRBEDFN,"ORDGX")="O"
S LRBEAR(LRBEDFN,"DOS")=LRBECDT
S LRBEAR(LRBEDFN,"PAT")=$G(LRBEDFN)
S LRBEAR(LRBEDFN,"POS")=LROOS
S LRBEAR(LRBEDFN,"DEL")=LRBEDEL
S LRBEAR(LRBEDFN,"USR")=DUZ
S LRBEIEN=LRSN_","_LRODT_","
S LRBEAR(LRBEDFN,"ORDPRO")=$$GET1^DIQ(69.01,LRBEIEN,7,"I")
S:'+$G(LRSAMP) LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
;reset LRBETEST, LRBEY for panel tests
S LRBETS="" F S LRBETS=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS)) Q:'LRBETS D
.S LRJ=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS,0))
.Q:($P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,9)="CA")
.I $G(ORIEN),$P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,7)'=ORIEN Q
.I ($G(^LAB(60,LRBETS,12))),($D(^LAB(60,LRBETS,0))#2),'$L($P($G(^LAB(60,LRBETS,0)),U,5)) S LRBEPAN(LRBETS)=""
.S OK=0,N=0 F S N=$O(LRBETEST(N)) Q:'N I LRBETS=+LRBETEST(N) S OK=1
.I 'OK S N=$O(LRBETEST(""),-1),N=N+1,LRBETEST(N)=LRBETS_U_^LAB(60,LRBETS,0),LRBETEST(N,"P")=LRBETS_U_$$NLT^LRVER1(LRBETS)
.S NX=0 F S NX=$O(^LAB(60,LRBETS,2,NX)) Q:'NX D
..S X=+^LAB(60,LRBETS,2,NX,0)
..S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
..I XX,$D(LRBESB(XX)) S P(LRBETS,XX,X)=""
..I XX,$D(LRBEPAN(LRBETS)),REQX S P(LRBETS,XX,X)="R"
..;if XX null, then possibly another panel
..I 'XX D PARRAY(X,LRBETS,.P)
.;reset LRBEY array;
.;1st subscript is panel test; 2nd subscript is data identifier of atomic test
.I $D(P(LRBETS)) D
..;retain original LRBEY array node if atomic test exists as a separate accession
..I '$D(^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN),4,LRBETS,0)) K LRBEY(LRBETS)
..S XX=0 F S XX=$O(P(LRBETS,XX)) Q:'XX D
...S LRBEY(LRBETS,XX)=""
...S X=$O(P(LRBETS,XX,0))
...I P(LRBETS,XX,X)="R" S LRBEY(LRBETS,XX,"R")=X
;continue
S LRBETS="" F S LRBETS=$O(LRBETEST(LRBETS)) Q:LRBETS="" D
.S LRBETST=$P(LRBETEST(LRBETS),U,1)
.D BLDAR^LRBEBA2(LRBEDFN,LRODT,LRSN,LRBETS,LRSAMP,LRSPEC,LRBETST,.LRBEAR)
Q
;
PARRAY(XTEST,PTEST,P) ;
N NX,X,XX,REQX
S NX=0 F S NX=$O(^LAB(60,XTEST,2,NX)) Q:'NX D
.S X=+^LAB(60,XTEST,2,NX,0)
.S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
.I XX,$D(LRBESB(XX)) S P(PTEST,XX,X)=""
.I XX,$D(LRBEPAN(PTEST)),REQX S P(PTEST,XX,X)="R"
Q
;
QRYADD(LRODT,LRSN,LRTS,LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRBEX,LRBEXD) ; Query #69 for
; default LRBEDGX and SC/EI
N LRBEA,LRDGX,LRDX,LRDGXD
S LRDGX=0
F S LRDGX=$O(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX)) Q:LRDGX<1 D
.S LRDGXD=2
.S LRBEPTDT=$G(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX,0)) Q:'LRBEPTDT
.S LRBEA=$P(LRBEPTDT,U,1)_"^^^"_$P(LRBEPTDT,U,4)_U_$P(LRBEPTDT,U,5)
.S LRBEA=LRBEA_U_$P(LRBEPTDT,U,2)_U_$P(LRBEPTDT,U,6)_U_$P(LRBEPTDT,U,8)
.S LRBEA=LRBEA_U_$P(LRBEPTDT,U,7)_U_$P(LRBEPTDT,U,3)_U_$P(LRBEPTDT,U,10)
.I $P(LRBEPTDT,U,9)=1 S LRBEA=LRBEA_U_$P(LRBEPTDT,U,9),LRDGXD=1
.S LRBEX(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,$P(LRBEA,U))=LRBEA
.S LRBEXD(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,LRDGXD,$P(LRBEA,U))=LRBEA
Q
;
ELIG(DFN) ; Display eligibility and disabilities
D ELIG^VADPT W !," Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
W !," Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
.S LRDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),LRCNT=$P(I1,"^",2)
.S LRDIS=$E(LRDIS,1,55)
.I LRDIS]"" W ?15,LRDIS_" - "_LRCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_")",!
K LRDIS,LRCNT,I,I1,VAEL
Q
;
BALROW(LRODT,LRSN,LRTEST) ; CIDC LROW
N LRBEA,LRBEB,LRBEAT,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEOT,LRBEVAL
S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
S:$G(LRSN)="" LRSN=1
D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT) S:$G(LRSS)="" LRSS="CH"
S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LRBEOT)
Q
;
AQ1 ; Ask question from LRORD1
N LRBEVAL
S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
K LRBEODT D DT^LRX S LRBEODT=%
S:$G(LRSS)="" LRSS="CH"
S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
Q
;
AQ2 ; from LROW2A
N LRBEVAL
S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSSP,LRSPEC,$P(LRTEST(LRI),U,1),.LRBEX)
Q
;
SVST(ENUM,ETYP,LRODT,LRSN) ; Set the Encounter # in #69
S ^LRO(69,LRODT,1,LRSN,ETYP)=ENUM
Q
;
BALROR(LRORD) ; CIDC LRORD
N LRBEA,LRBEAT,LRBEB,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEODT
N LRBEOT,LRBEVAL,LRBEZ,LRBETN
S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
Q
;
SLROT(LRXST,LRTEST,LRBEOT) ;LROT array
N LRBEA,LRBESMP,LRBESPC
S LRBESMP="" F S LRBESMP=$O(LRXST(LRBESMP)) Q:LRBESMP="" D
.S LRBEA="" F S LRBEA=$O(LRXST(LRBESMP,LRBEA)) Q:LRBEA="" D
..S LRBESPC=$P(LRXST(LRBESMP,LRBEA),U,1)
..S LRBEOT(LRBESMP,LRBESPC,LRBEA)=$P(LRTEST(LRBEA),U,1)
Q
;
MICRO1(LRODT,LRSN,LRTST,LRCNT) ;get CIDC data for microbiology
;called from LRCAPPH1
N LRBETM
N AA,DX,DXCNT,FINAL,GOPRO,GEPRO,MOD,ORD,N,X
S FINAL=$$FINAL^LRBEBA3(LRODT,LRSN,LRTST)
I $P(FINAL,U)=0 K ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT) Q
;continue if micro test completed
S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
S LRBETM=$P($G(^LRO(69,LRODT,1,LRSN,3)),U) I 'LRBETM S LRBETM=LRODT
S LRBETM=$$PCETM^LRBEBAO(LRBETM)
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"EVENT D/T")=LRBETM
S AA=$P($P(FINAL,";",2),U,4)
S GOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
S GEPRO=$$GEPRO^LRBEBA4(AA)
S ^TMP("LRPXAPI",$J,"PROVIDER",1,"NAME")=GOPRO
S ^TMP("LRPXAPI",$J,"PROVIDER",1,"PRIMARY")=1
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD PROVIDER")=GOPRO
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ENC PROVIDER")=GEPRO
S ORD=$P($P(FINAL,";",2),U,7)
S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD REFERENCE")=ORD
S ^TMP("LRBEDX",$J,"ID")=LRODT_U_LRSN
S N=0 F S N=$O(^LRO(69,LRODT,1,LRSN,2,LRTST,2,N)) Q:'N Q:N>4 D
.S X=^LRO(69,LRODT,1,LRSN,2,LRTST,2,N,0)
.S DXCNT=DXCNT+1,^TMP("LRBEDX",$J,DXCNT)=X
.I N=1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS")=$P(X,U,1)
.I N>1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS "_N)=$P(X,U,1)
Q
;
MICRO2(LRODT,LRSN) ;setup more CIDC data for microbiology
;called from LRCAPPH1
N DXCNT,EI,EIX,X
S X=$G(^TMP("LRBEDX",$J,"ID"))
I ($P(X,U)'=LRODT)!($P(X,U,2)'=LRSN) Q
S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
Q:'DXCNT
S DXCNT=0 F S DXCNT=$O(^TMP("LRBEDX",$J,DXCNT)) Q:'DXCNT D
.S X=^TMP("LRBEDX",$J,DXCNT)
.S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"DIAGNOSIS")=$P(X,U,1)
.I $P(X,U,2)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL SC")=$P(X,U,2),EIX("SC")=$G(EIX("SC"))+$P(X,U,2)
.I $P(X,U,3)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL CV")=$P(X,U,3),EIX("CV")=$G(EIX("CV"))+$P(X,U,3)
.I $P(X,U,4)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL AO")=$P(X,U,4),EIX("AO")=$G(EIX("AO"))+$P(X,U,4)
.I $P(X,U,5)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL IR")=$P(X,U,5),EIX("IR")=$G(EIX("IR"))+$P(X,U,5)
.I $P(X,U,6)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL EC")=$P(X,U,6),EIX("EC")=$G(EIX("EC"))+$P(X,U,6)
.I $P(X,U,7)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL MST")=$P(X,U,7),EIX("MST")=$G(EIX("MST"))+$P(X,U,7)
.I $P(X,U,8)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL HNC")=$P(X,U,8),EIX("HNC")=$G(EIX("HNC"))+$P(X,U,8)
.I $P(X,U,10)'="" S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PL SHAD")=$P(X,U,10),EIX("SHAD")=$G(EIX("SHAD"))+$P(X,U,10)
.I $P(X,U,9) S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PRIMARY")=$P(X,U,9)
F EI="SC","CV","AO","IR","EC","MST","HNC","SHAD" D
.I $G(EIX(EI))>1 S EIX(EI)=1
.I $G(EIX(EI))'="" S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,EI)=EIX(EI)
Q
;
FINAL(LRODT,LRSN,LRTST) ;is microbiology test complete/final?
;called from MICRO1 only
;returns 1_";"_<0-node of order>, if test completed
; otherwise returns 0
N AA,AI,AY,NODEO,NODEA,NOKILL,RETURN,TST,TT,X,LRCEX,LROA
S LRCEX=$P($G(^LRO(69,LRODT,1,LRSN,.1)),U)
S LROA=LRODT_"|"_LRSN
S RETURN=0,NODEA=""
S NODEO=$G(^LRO(69,LRODT,1,LRSN,2,LRTST,0))
S TST=$P(NODEO,U),AY=$P(NODEO,U,3),AA=$P(NODEO,U,4),AI=$P(NODEO,U,5)
I TST,AA,AI,AY S NODEA=$G(^LRO(68,AA,1,AY,1,AI,4,TST,0))
;does complete date exist?
I $P(NODEA,U,5) S RETURN=1_";"_NODEO
I RETURN'=0 D
.S $P(^LRO(69,LRODT,1,LRSN,2,LRTST,0),U,12)=1
.S NOKILL=0
.S TT=0 F S TT=$O(^LRO(69,LRODT,1,LRSN,2,TT)) Q:'TT D
..S NODEO=^LRO(69,LRODT,1,LRSN,2,TT,0),AA=$P(NODEO,U,4)
..I AA,$P(NODEO,U,12)'=1,$P($G(^LRO(68,AA,0)),U,2)="MI" S NOKILL=1
.I NOKILL=0 S ^LRO(69,"AA",LRCEX,LROA)=""
Q RETURN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBEBA3 9016 printed Sep 23, 2025@19:45:38 Page 2
LRBEBA3 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;10/04/11
+1 ;;5.2;LAB SERVICE;**291,359,352,350**;Sep 27, 1994;Build 230
+2 ;
BLDAR(LRBEDFN,LRODT,LRSN,LRBEAR,LRBEY,LRBETEST,LRBEPAN,LRBEDEL) ; Build LRBEAR array with
+1 ; CIDC information
+2 NEW LRBEODT,LRBEIEN,LRBETST,LRBETS,LRJ,N,NX,P,X,XX,REQX,OK
+3 SET LRBEAR(LRBEDFN,"DSS ID")=LROOS
+4 SET LRBEAR(LRBEDFN,"ORDGX")="O"
+5 SET LRBEAR(LRBEDFN,"DOS")=LRBECDT
+6 SET LRBEAR(LRBEDFN,"PAT")=$GET(LRBEDFN)
+7 SET LRBEAR(LRBEDFN,"POS")=LROOS
+8 SET LRBEAR(LRBEDFN,"DEL")=LRBEDEL
+9 SET LRBEAR(LRBEDFN,"USR")=DUZ
+10 SET LRBEIEN=LRSN_","_LRODT_","
+11 SET LRBEAR(LRBEDFN,"ORDPRO")=$$GET1^DIQ(69.01,LRBEIEN,7,"I")
+12 if '+$GET(LRSAMP)
SET LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
+13 ;reset LRBETEST, LRBEY for panel tests
+14 SET LRBETS=""
FOR
SET LRBETS=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS))
if 'LRBETS
QUIT
Begin DoDot:1
+15 SET LRJ=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS,0))
+16 if ($PIECE(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,9)="CA")
QUIT
+17 IF $GET(ORIEN)
IF $PIECE(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,7)'=ORIEN
QUIT
+18 IF ($GET(^LAB(60,LRBETS,12)))
IF ($DATA(^LAB(60,LRBETS,0))#2)
IF '$LENGTH($PIECE($GET(^LAB(60,LRBETS,0)),U,5))
SET LRBEPAN(LRBETS)=""
+19 SET OK=0
SET N=0
FOR
SET N=$ORDER(LRBETEST(N))
if 'N
QUIT
IF LRBETS=+LRBETEST(N)
SET OK=1
+20 IF 'OK
SET N=$ORDER(LRBETEST(""),-1)
SET N=N+1
SET LRBETEST(N)=LRBETS_U_^LAB(60,LRBETS,0)
SET LRBETEST(N,"P")=LRBETS_U_$$NLT^LRVER1(LRBETS)
+21 SET NX=0
FOR
SET NX=$ORDER(^LAB(60,LRBETS,2,NX))
if 'NX
QUIT
Begin DoDot:2
+22 SET X=+^LAB(60,LRBETS,2,NX,0)
+23 SET XX=$PIECE($PIECE(^LAB(60,X,0),U,5),";",2)
SET REQX=$PIECE(^(0),U,17)
+24 IF XX
IF $DATA(LRBESB(XX))
SET P(LRBETS,XX,X)=""
+25 IF XX
IF $DATA(LRBEPAN(LRBETS))
IF REQX
SET P(LRBETS,XX,X)="R"
+26 ;if XX null, then possibly another panel
+27 IF 'XX
DO PARRAY(X,LRBETS,.P)
End DoDot:2
+28 ;reset LRBEY array;
+29 ;1st subscript is panel test; 2nd subscript is data identifier of atomic test
+30 IF $DATA(P(LRBETS))
Begin DoDot:2
+31 ;retain original LRBEY array node if atomic test exists as a separate accession
+32 IF '$DATA(^LRO(68,$GET(LRAA),1,$GET(LRAD),1,$GET(LRAN),4,LRBETS,0))
KILL LRBEY(LRBETS)
+33 SET XX=0
FOR
SET XX=$ORDER(P(LRBETS,XX))
if 'XX
QUIT
Begin DoDot:3
+34 SET LRBEY(LRBETS,XX)=""
+35 SET X=$ORDER(P(LRBETS,XX,0))
+36 IF P(LRBETS,XX,X)="R"
SET LRBEY(LRBETS,XX,"R")=X
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;continue
+38 SET LRBETS=""
FOR
SET LRBETS=$ORDER(LRBETEST(LRBETS))
if LRBETS=""
QUIT
Begin DoDot:1
+39 SET LRBETST=$PIECE(LRBETEST(LRBETS),U,1)
+40 DO BLDAR^LRBEBA2(LRBEDFN,LRODT,LRSN,LRBETS,LRSAMP,LRSPEC,LRBETST,.LRBEAR)
End DoDot:1
+41 QUIT
+42 ;
PARRAY(XTEST,PTEST,P) ;
+1 NEW NX,X,XX,REQX
+2 SET NX=0
FOR
SET NX=$ORDER(^LAB(60,XTEST,2,NX))
if 'NX
QUIT
Begin DoDot:1
+3 SET X=+^LAB(60,XTEST,2,NX,0)
+4 SET XX=$PIECE($PIECE(^LAB(60,X,0),U,5),";",2)
SET REQX=$PIECE(^(0),U,17)
+5 IF XX
IF $DATA(LRBESB(XX))
SET P(PTEST,XX,X)=""
+6 IF XX
IF $DATA(LRBEPAN(PTEST))
IF REQX
SET P(PTEST,XX,X)="R"
End DoDot:1
+7 QUIT
+8 ;
QRYADD(LRODT,LRSN,LRTS,LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRBEX,LRBEXD) ; Query #69 for
+1 ; default LRBEDGX and SC/EI
+2 NEW LRBEA,LRDGX,LRDX,LRDGXD
+3 SET LRDGX=0
+4 FOR
SET LRDGX=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX))
if LRDGX<1
QUIT
Begin DoDot:1
+5 SET LRDGXD=2
+6 SET LRBEPTDT=$GET(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX,0))
if 'LRBEPTDT
QUIT
+7 SET LRBEA=$PIECE(LRBEPTDT,U,1)_"^^^"_$PIECE(LRBEPTDT,U,4)_U_$PIECE(LRBEPTDT,U,5)
+8 SET LRBEA=LRBEA_U_$PIECE(LRBEPTDT,U,2)_U_$PIECE(LRBEPTDT,U,6)_U_$PIECE(LRBEPTDT,U,8)
+9 SET LRBEA=LRBEA_U_$PIECE(LRBEPTDT,U,7)_U_$PIECE(LRBEPTDT,U,3)_U_$PIECE(LRBEPTDT,U,10)
+10 IF $PIECE(LRBEPTDT,U,9)=1
SET LRBEA=LRBEA_U_$PIECE(LRBEPTDT,U,9)
SET LRDGXD=1
+11 SET LRBEX(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,$PIECE(LRBEA,U))=LRBEA
+12 SET LRBEXD(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,LRDGXD,$PIECE(LRBEA,U))=LRBEA
End DoDot:1
+13 QUIT
+14 ;
ELIG(DFN) ; Display eligibility and disabilities
+1 DO ELIG^VADPT
WRITE !," Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
+2 WRITE !," Disabilities: "
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+3 SET LRDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET LRCNT=$PIECE(I1,"^",2)
+4 SET LRDIS=$EXTRACT(LRDIS,1,55)
+5 IF LRDIS]""
WRITE ?15,LRDIS_" - "_LRCNT_"%("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_")",!
End DoDot:1
+6 KILL LRDIS,LRCNT,I,I1,VAEL
+7 QUIT
+8 ;
BALROW(LRODT,LRSN,LRTEST) ; CIDC LROW
+1 NEW LRBEA,LRBEB,LRBEAT,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEOT,LRBEVAL
+2 SET LRBEVAL=$DATA(^XUSEC("PROVIDER",DUZ))
if 'LRBEVAL
QUIT
+3 SET LRBEVAL=$$CIDC^IBBAPI(DFN)
if 'LRBEVAL
QUIT
+4 IF '$DATA(DFN)
SET LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
+5 if $GET(LRSN)=""
SET LRSN=1
+6 DO SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT)
if $GET(LRSS)=""
SET LRSS="CH"
+7 SET LRBEAT=1
SET LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LRBEOT)
+8 QUIT
+9 ;
AQ1 ; Ask question from LRORD1
+1 NEW LRBEVAL
+2 SET LRBEVAL=$DATA(^XUSEC("PROVIDER",DUZ))
if 'LRBEVAL
QUIT
+3 SET LRBEVAL=$$CIDC^IBBAPI(DFN)
if 'LRBEVAL
QUIT
+4 KILL LRBEODT
DO DT^LRX
SET LRBEODT=%
+5 if $GET(LRSS)=""
SET LRSS="CH"
+6 SET LRBEAT=1
SET LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
+7 QUIT
+8 ;
AQ2 ; from LROW2A
+1 NEW LRBEVAL
+2 SET LRBEVAL=$$CIDC^IBBAPI(DFN)
if 'LRBEVAL
QUIT
+3 DO SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSSP,LRSPEC,$PIECE(LRTEST(LRI),U,1),.LRBEX)
+4 QUIT
+5 ;
SVST(ENUM,ETYP,LRODT,LRSN) ; Set the Encounter # in #69
+1 SET ^LRO(69,LRODT,1,LRSN,ETYP)=ENUM
+2 QUIT
+3 ;
BALROR(LRORD) ; CIDC LRORD
+1 NEW LRBEA,LRBEAT,LRBEB,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEODT
+2 NEW LRBEOT,LRBEVAL,LRBEZ,LRBETN
+3 SET LRBEVAL=$DATA(^XUSEC("PROVIDER",DUZ))
if 'LRBEVAL
QUIT
+4 SET LRBEVAL=$$CIDC^IBBAPI(DFN)
if 'LRBEVAL
QUIT
+5 IF '$DATA(DFN)
SET LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
+6 SET LRBEAT=1
SET LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
+7 QUIT
+8 ;
SLROT(LRXST,LRTEST,LRBEOT) ;LROT array
+1 NEW LRBEA,LRBESMP,LRBESPC
+2 SET LRBESMP=""
FOR
SET LRBESMP=$ORDER(LRXST(LRBESMP))
if LRBESMP=""
QUIT
Begin DoDot:1
+3 SET LRBEA=""
FOR
SET LRBEA=$ORDER(LRXST(LRBESMP,LRBEA))
if LRBEA=""
QUIT
Begin DoDot:2
+4 SET LRBESPC=$PIECE(LRXST(LRBESMP,LRBEA),U,1)
+5 SET LRBEOT(LRBESMP,LRBESPC,LRBEA)=$PIECE(LRTEST(LRBEA),U,1)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
MICRO1(LRODT,LRSN,LRTST,LRCNT) ;get CIDC data for microbiology
+1 ;called from LRCAPPH1
+2 NEW LRBETM
+3 NEW AA,DX,DXCNT,FINAL,GOPRO,GEPRO,MOD,ORD,N,X
+4 SET FINAL=$$FINAL^LRBEBA3(LRODT,LRSN,LRTST)
+5 IF $PIECE(FINAL,U)=0
KILL ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT)
QUIT
+6 ;continue if micro test completed
+7 SET DXCNT=+$ORDER(^TMP("LRBEDX",$JOB,999),-1)
+8 SET LRBETM=$PIECE($GET(^LRO(69,LRODT,1,LRSN,3)),U)
IF 'LRBETM
SET LRBETM=LRODT
+9 SET LRBETM=$$PCETM^LRBEBAO(LRBETM)
+10 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"EVENT D/T")=LRBETM
+11 SET AA=$PIECE($PIECE(FINAL,";",2),U,4)
+12 SET GOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
+13 SET GEPRO=$$GEPRO^LRBEBA4(AA)
+14 SET ^TMP("LRPXAPI",$JOB,"PROVIDER",1,"NAME")=GOPRO
+15 SET ^TMP("LRPXAPI",$JOB,"PROVIDER",1,"PRIMARY")=1
+16 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"ORD PROVIDER")=GOPRO
+17 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"ENC PROVIDER")=GEPRO
+18 SET ORD=$PIECE($PIECE(FINAL,";",2),U,7)
+19 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"ORD REFERENCE")=ORD
+20 SET ^TMP("LRBEDX",$JOB,"ID")=LRODT_U_LRSN
+21 SET N=0
FOR
SET N=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTST,2,N))
if 'N
QUIT
if N>4
QUIT
Begin DoDot:1
+22 SET X=^LRO(69,LRODT,1,LRSN,2,LRTST,2,N,0)
+23 SET DXCNT=DXCNT+1
SET ^TMP("LRBEDX",$JOB,DXCNT)=X
+24 IF N=1
SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"DIAGNOSIS")=$PIECE(X,U,1)
+25 IF N>1
SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRCNT,"DIAGNOSIS "_N)=$PIECE(X,U,1)
End DoDot:1
+26 QUIT
+27 ;
MICRO2(LRODT,LRSN) ;setup more CIDC data for microbiology
+1 ;called from LRCAPPH1
+2 NEW DXCNT,EI,EIX,X
+3 SET X=$GET(^TMP("LRBEDX",$JOB,"ID"))
+4 IF ($PIECE(X,U)'=LRODT)!($PIECE(X,U,2)'=LRSN)
QUIT
+5 SET DXCNT=+$ORDER(^TMP("LRBEDX",$JOB,999),-1)
+6 if 'DXCNT
QUIT
+7 SET DXCNT=0
FOR
SET DXCNT=$ORDER(^TMP("LRBEDX",$JOB,DXCNT))
if 'DXCNT
QUIT
Begin DoDot:1
+8 SET X=^TMP("LRBEDX",$JOB,DXCNT)
+9 SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"DIAGNOSIS")=$PIECE(X,U,1)
+10 IF $PIECE(X,U,2)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL SC")=$PIECE(X,U,2)
SET EIX("SC")=$GET(EIX("SC"))+$PIECE(X,U,2)
+11 IF $PIECE(X,U,3)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL CV")=$PIECE(X,U,3)
SET EIX("CV")=$GET(EIX("CV"))+$PIECE(X,U,3)
+12 IF $PIECE(X,U,4)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL AO")=$PIECE(X,U,4)
SET EIX("AO")=$GET(EIX("AO"))+$PIECE(X,U,4)
+13 IF $PIECE(X,U,5)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL IR")=$PIECE(X,U,5)
SET EIX("IR")=$GET(EIX("IR"))+$PIECE(X,U,5)
+14 IF $PIECE(X,U,6)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL EC")=$PIECE(X,U,6)
SET EIX("EC")=$GET(EIX("EC"))+$PIECE(X,U,6)
+15 IF $PIECE(X,U,7)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL MST")=$PIECE(X,U,7)
SET EIX("MST")=$GET(EIX("MST"))+$PIECE(X,U,7)
+16 IF $PIECE(X,U,8)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL HNC")=$PIECE(X,U,8)
SET EIX("HNC")=$GET(EIX("HNC"))+$PIECE(X,U,8)
+17 IF $PIECE(X,U,10)'=""
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PL SHAD")=$PIECE(X,U,10)
SET EIX("SHAD")=$GET(EIX("SHAD"))+$PIECE(X,U,10)
+18 IF $PIECE(X,U,9)
SET ^TMP("LRPXAPI",$JOB,"DX/PL",DXCNT,"PRIMARY")=$PIECE(X,U,9)
End DoDot:1
+19 FOR EI="SC","CV","AO","IR","EC","MST","HNC","SHAD"
Begin DoDot:1
+20 IF $GET(EIX(EI))>1
SET EIX(EI)=1
+21 IF $GET(EIX(EI))'=""
SET ^TMP("LRPXAPI",$JOB,"ENCOUNTER",1,EI)=EIX(EI)
End DoDot:1
+22 QUIT
+23 ;
FINAL(LRODT,LRSN,LRTST) ;is microbiology test complete/final?
+1 ;called from MICRO1 only
+2 ;returns 1_";"_<0-node of order>, if test completed
+3 ; otherwise returns 0
+4 NEW AA,AI,AY,NODEO,NODEA,NOKILL,RETURN,TST,TT,X,LRCEX,LROA
+5 SET LRCEX=$PIECE($GET(^LRO(69,LRODT,1,LRSN,.1)),U)
+6 SET LROA=LRODT_"|"_LRSN
+7 SET RETURN=0
SET NODEA=""
+8 SET NODEO=$GET(^LRO(69,LRODT,1,LRSN,2,LRTST,0))
+9 SET TST=$PIECE(NODEO,U)
SET AY=$PIECE(NODEO,U,3)
SET AA=$PIECE(NODEO,U,4)
SET AI=$PIECE(NODEO,U,5)
+10 IF TST
IF AA
IF AI
IF AY
SET NODEA=$GET(^LRO(68,AA,1,AY,1,AI,4,TST,0))
+11 ;does complete date exist?
+12 IF $PIECE(NODEA,U,5)
SET RETURN=1_";"_NODEO
+13 IF RETURN'=0
Begin DoDot:1
+14 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTST,0),U,12)=1
+15 SET NOKILL=0
+16 SET TT=0
FOR
SET TT=$ORDER(^LRO(69,LRODT,1,LRSN,2,TT))
if 'TT
QUIT
Begin DoDot:2
+17 SET NODEO=^LRO(69,LRODT,1,LRSN,2,TT,0)
SET AA=$PIECE(NODEO,U,4)
+18 IF AA
IF $PIECE(NODEO,U,12)'=1
IF $PIECE($GET(^LRO(68,AA,0)),U,2)="MI"
SET NOKILL=1
End DoDot:2
+19 IF NOKILL=0
SET ^LRO(69,"AA",LRCEX,LROA)=""
End DoDot:1
+20 QUIT RETURN
