196 lines
8.4 KiB
Mathematica
196 lines
8.4 KiB
Mathematica
LRBEBA3 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
|
|
;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
|
|
;
|
|
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)
|
|
.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^LRBEBA2(LRODT,LRSN)
|
|
S GEPRO=$$GEPRO^LRBEBA2(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,9) S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PRIMARY")=$P(X,U,9)
|
|
F EI="SC","CV","AO","IR","EC","MST","HNC" 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
|
|
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
|