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

LRBEBA3.m

Go to the documentation of this file. 
  1. LRBEBA3 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
  1.  ;;5.2;LAB SERVICE;**1031**;Nov 1, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 291,359,352
  1.  ;
  1. BLDAR(LRBEDFN,LRODT,LRSN,LRBEAR,LRBEY,LRBETEST,LRBEPAN,LRBEDEL) ; Build LRBEAR array with
  1.  Q:'$$MODEXIST^BLRUTIL4("EAS")         ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  ; CIDC information
  1.  N LRBEODT,LRBEIEN,LRBETST,LRBETS,LRJ,N,NX,P,X,XX,REQX,OK
  1.  S LRBEAR(LRBEDFN,"DSS ID")=LROOS
  1.  S LRBEAR(LRBEDFN,"ORDGX")="O"
  1.  S LRBEAR(LRBEDFN,"DOS")=LRBECDT
  1.  S LRBEAR(LRBEDFN,"PAT")=$G(LRBEDFN)
  1.  S LRBEAR(LRBEDFN,"POS")=LROOS
  1.  S LRBEAR(LRBEDFN,"DEL")=LRBEDEL
  1.  S LRBEAR(LRBEDFN,"USR")=DUZ
  1.  S LRBEIEN=LRSN_","_LRODT_","
  1.  S LRBEAR(LRBEDFN,"ORDPRO")=$$GET1^DIQ(69.01,LRBEIEN,7,"I")
  1.  S:'+$G(LRSAMP) LRSAMP=$$GET1^DIQ(69.01,LRBEIEN,3,"I")
  1.  ;reset LRBETEST, LRBEY for panel tests
  1.  S LRBETS="" F  S LRBETS=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS)) Q:'LRBETS  D
  1.  .S LRJ=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETS,0))
  1.  .Q:($P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,9)="CA")
  1.  .I $G(ORIEN),$P(^LRO(69,LRODT,1,LRSN,2,LRJ,0),U,7)'=ORIEN Q
  1.  .I ($G(^LAB(60,LRBETS,12))),($D(^LAB(60,LRBETS,0))#2),'$L($P($G(^LAB(60,LRBETS,0)),U,5)) S LRBEPAN(LRBETS)=""
  1.  .S OK=0,N=0 F  S N=$O(LRBETEST(N)) Q:'N  I LRBETS=+LRBETEST(N) S OK=1
  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)
  1.  .S NX=0 F  S NX=$O(^LAB(60,LRBETS,2,NX)) Q:'NX  D
  1.  ..S X=+^LAB(60,LRBETS,2,NX,0)
  1.  ..S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
  1.  ..I XX,$D(LRBESB(XX)) S P(LRBETS,XX,X)=""
  1.  ..I XX,$D(LRBEPAN(LRBETS)),REQX S P(LRBETS,XX,X)="R"
  1.  ..;if XX null, then possibly another panel
  1.  ..I 'XX D PARRAY(X,LRBETS,.P)
  1.  .;reset LRBEY array;
  1.  .;1st subscript is panel test; 2nd subscript is data identifier of atomic test
  1.  .I $D(P(LRBETS)) D
  1.  ..;retain original LRBEY array node if atomic test exists as a separate accession
  1.  ..I '$D(^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN),4,LRBETS,0)) K LRBEY(LRBETS)
  1.  ..S XX=0 F  S XX=$O(P(LRBETS,XX)) Q:'XX  D
  1.  ...S LRBEY(LRBETS,XX)=""
  1.  ...S X=$O(P(LRBETS,XX,0))
  1.  ...I P(LRBETS,XX,X)="R" S LRBEY(LRBETS,XX,"R")=X
  1.  ;continue
  1.  S LRBETS="" F  S LRBETS=$O(LRBETEST(LRBETS)) Q:LRBETS=""  D
  1.  .S LRBETST=$P(LRBETEST(LRBETS),U,1)
  1.  .D BLDAR^LRBEBA2(LRBEDFN,LRODT,LRSN,LRBETS,LRSAMP,LRSPEC,LRBETST,.LRBEAR)
  1.  Q
  1.  ;
  1. PARRAY(XTEST,PTEST,P) ;
  1.  N NX,X,XX,REQX
  1.  S NX=0 F  S NX=$O(^LAB(60,XTEST,2,NX)) Q:'NX  D
  1.  .S X=+^LAB(60,XTEST,2,NX,0)
  1.  .S XX=$P($P(^LAB(60,X,0),U,5),";",2),REQX=$P(^(0),U,17)
  1.  .I XX,$D(LRBESB(XX)) S P(PTEST,XX,X)=""
  1.  .I XX,$D(LRBEPAN(PTEST)),REQX S P(PTEST,XX,X)="R"
  1.  Q
  1.  ;
  1. QRYADD(LRODT,LRSN,LRTS,LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRBEX,LRBEXD) ; Query #69 for
  1.  Q:'$$MODEXIST^BLRUTIL4("EAS")         ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  ; default LRBEDGX and SC/EI
  1.  N LRBEA,LRDGX,LRDX,LRDGXD
  1.  S LRDGX=0
  1.  F  S LRDGX=$O(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX)) Q:LRDGX<1  D
  1.  .S LRDGXD=2
  1.  .S LRBEPTDT=$G(^LRO(69,LRODT,1,LRSN,2,LRTS,2,LRDGX,0)) Q:'LRBEPTDT
  1.  .S LRBEA=$P(LRBEPTDT,U,1)_"^^^"_$P(LRBEPTDT,U,4)_U_$P(LRBEPTDT,U,5)
  1.  .S LRBEA=LRBEA_U_$P(LRBEPTDT,U,2)_U_$P(LRBEPTDT,U,6)_U_$P(LRBEPTDT,U,8)
  1.  .S LRBEA=LRBEA_U_$P(LRBEPTDT,U,7)_U_$P(LRBEPTDT,U,3)_U_$P(LRBEPTDT,U,10)
  1.  .I $P(LRBEPTDT,U,9)=1 S LRBEA=LRBEA_U_$P(LRBEPTDT,U,9),LRDGXD=1
  1.  .S LRBEX(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,$P(LRBEA,U))=LRBEA
  1.  .S LRBEXD(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS,LRDGXD,$P(LRBEA,U))=LRBEA
  1.  Q
  1.  ;
  1. ELIG(DFN) ; Display eligibility and disabilities
  1.  Q:'$$MODEXIST^BLRUTIL4("EAS")         ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  D ELIG^VADPT W !," Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"    SC%: "_$P(VAEL(3),"^",2),1:"")
  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
  1.  .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)
  1.  .S LRDIS=$E(LRDIS,1,55)
  1.  .I LRDIS]"" W ?15,LRDIS_" - "_LRCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_")",!
  1.  K LRDIS,LRCNT,I,I1,VAEL
  1.  Q
  1.  ;
  1. BALROW(LRODT,LRSN,LRTEST) ; CIDC LROW
  1.  Q:'$$MODEXIST^BLRUTIL4("IB")          ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  N LRBEA,LRBEB,LRBEAT,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEOT,LRBEVAL
  1.  S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
  1.  S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
  1.  I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
  1.  S:$G(LRSN)="" LRSN=1
  1.  D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT) S:$G(LRSS)="" LRSS="CH"
  1.  S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LRBEOT)
  1.  Q
  1.  ;
  1. AQ1 ; Ask question from LRORD1
  1.  Q:'$$MODEXIST^BLRUTIL4("IB")          ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  N LRBEVAL
  1.  S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
  1.  S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
  1.  K LRBEODT D DT^LRX S LRBEODT=%
  1.  S:$G(LRSS)="" LRSS="CH"
  1.  S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
  1.  Q
  1.  ;
  1. AQ2 ; from LROW2A
  1.  Q:'$$MODEXIST^BLRUTIL4("IB")          ; IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  N LRBEVAL
  1.  S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
  1.  D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSSP,LRSPEC,$P(LRTEST(LRI),U,1),.LRBEX)
  1.  Q
  1.  ;
  1. SVST(ENUM,ETYP,LRODT,LRSN) ; Set the Encounter # in #69
  1.  S ^LRO(69,LRODT,1,LRSN,ETYP)=ENUM
  1.  Q
  1.  ;
  1. BALROR(LRORD) ; CIDC LRORD
  1.  Q:'$$MODEXIST^BLRUTIL4("IB")          ; IHS/MSC/MKK -- LR*5.2*1031
  1.  ;
  1.  N LRBEA,LRBEAT,LRBEB,LRBET,LRBESN,LRBETS,LRBETST,LRBEQT,LRBEODT
  1.  N LRBEOT,LRBEVAL,LRBEZ,LRBETN
  1.  S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ)) Q:'LRBEVAL
  1.  S LRBEVAL=$$CIDC^IBBAPI(DFN) Q:'LRBEVAL
  1.  I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
  1.  S LRBEAT=1,LRBEY=$$SBA^LRBEBA31(LRDFN,.LRBEX,.LRBEQT,.LROT)
  1.  Q
  1.  ;
  1. SLROT(LRXST,LRTEST,LRBEOT) ;LROT array
  1.  N LRBEA,LRBESMP,LRBESPC
  1.  S LRBESMP="" F  S LRBESMP=$O(LRXST(LRBESMP)) Q:LRBESMP=""  D
  1.  .S LRBEA="" F  S LRBEA=$O(LRXST(LRBESMP,LRBEA)) Q:LRBEA=""  D
  1.  ..S LRBESPC=$P(LRXST(LRBESMP,LRBEA),U,1)
  1.  ..S LRBEOT(LRBESMP,LRBESPC,LRBEA)=$P(LRTEST(LRBEA),U,1)
  1.  Q
  1.  ;
  1. MICRO1(LRODT,LRSN,LRTST,LRCNT) ;get CIDC data for microbiology
  1.  ;called from LRCAPPH1
  1.  N LRBETM
  1.  N AA,DX,DXCNT,FINAL,GOPRO,GEPRO,MOD,ORD,N,X
  1.  S FINAL=$$FINAL^LRBEBA3(LRODT,LRSN,LRTST)
  1.  I $P(FINAL,U)=0 K ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT) Q
  1.  ;continue if micro test completed
  1.  S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
  1.  S LRBETM=$P($G(^LRO(69,LRODT,1,LRSN,3)),U) I 'LRBETM S LRBETM=LRODT
  1.  S LRBETM=$$PCETM^LRBEBAO(LRBETM)
  1.  S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"EVENT D/T")=LRBETM
  1.  S AA=$P($P(FINAL,";",2),U,4)
  1.  S GOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN)
  1.  S GEPRO=$$GEPRO^LRBEBA4(AA)
  1.  S ^TMP("LRPXAPI",$J,"PROVIDER",1,"NAME")=GOPRO
  1.  S ^TMP("LRPXAPI",$J,"PROVIDER",1,"PRIMARY")=1
  1.  S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD PROVIDER")=GOPRO
  1.  S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ENC PROVIDER")=GEPRO
  1.  S ORD=$P($P(FINAL,";",2),U,7)
  1.  S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"ORD REFERENCE")=ORD
  1.  S ^TMP("LRBEDX",$J,"ID")=LRODT_U_LRSN
  1.  S N=0 F  S N=$O(^LRO(69,LRODT,1,LRSN,2,LRTST,2,N)) Q:'N  Q:N>4  D
  1.  .S X=^LRO(69,LRODT,1,LRSN,2,LRTST,2,N,0)
  1.  .S DXCNT=DXCNT+1,^TMP("LRBEDX",$J,DXCNT)=X
  1.  .I N=1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS")=$P(X,U,1)
  1.  .I N>1 S ^TMP("LRPXAPI",$J,"PROCEDURE",LRCNT,"DIAGNOSIS "_N)=$P(X,U,1)
  1.  Q
  1.  ;
  1. MICRO2(LRODT,LRSN) ;setup more CIDC data for microbiology
  1.  ;called from LRCAPPH1
  1.  N DXCNT,EI,EIX,X
  1.  S X=$G(^TMP("LRBEDX",$J,"ID"))
  1.  I ($P(X,U)'=LRODT)!($P(X,U,2)'=LRSN) Q
  1.  S DXCNT=+$O(^TMP("LRBEDX",$J,999),-1)
  1.  Q:'DXCNT
  1.  S DXCNT=0 F  S DXCNT=$O(^TMP("LRBEDX",$J,DXCNT)) Q:'DXCNT  D
  1.  .S X=^TMP("LRBEDX",$J,DXCNT)
  1.  .S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"DIAGNOSIS")=$P(X,U,1)
  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)
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .I $P(X,U,9) S ^TMP("LRPXAPI",$J,"DX/PL",DXCNT,"PRIMARY")=$P(X,U,9)
  1.  F EI="SC","CV","AO","IR","EC","MST","HNC","SHAD" D
  1.  .I $G(EIX(EI))>1 S EIX(EI)=1
  1.  .I $G(EIX(EI))'="" S ^TMP("LRPXAPI",$J,"ENCOUNTER",1,EI)=EIX(EI)
  1.  Q
  1.  ;
  1. FINAL(LRODT,LRSN,LRTST) ;is microbiology test complete/final?
  1.  ;called from MICRO1 only
  1.  ;returns 1_";"_<0-node of order>, if test completed
  1.  ;        otherwise returns 0
  1.  N AA,AI,AY,NODEO,NODEA,NOKILL,RETURN,TST,TT,X
  1.  S RETURN=0,NODEA=""
  1.  S NODEO=$G(^LRO(69,LRODT,1,LRSN,2,LRTST,0))
  1.  S TST=$P(NODEO,U),AY=$P(NODEO,U,3),AA=$P(NODEO,U,4),AI=$P(NODEO,U,5)
  1.  I TST,AA,AI,AY S NODEA=$G(^LRO(68,AA,1,AY,1,AI,4,TST,0))
  1.  ;does complete date exist?
  1.  I $P(NODEA,U,5) S RETURN=1_";"_NODEO
  1.  I RETURN'=0 D
  1.  .S $P(^LRO(69,LRODT,1,LRSN,2,LRTST,0),U,12)=1
  1.  .S NOKILL=0
  1.  .S TT=0 F  S TT=$O(^LRO(69,LRODT,1,LRSN,2,TT)) Q:'TT  D
  1.  ..S NODEO=^LRO(69,LRODT,1,LRSN,2,TT,0),AA=$P(NODEO,U,4)
  1.  ..I AA,$P(NODEO,U,12)'=1,$P($G(^LRO(68,AA,0)),U,2)="MI" S NOKILL=1
  1.  .I NOKILL=0 S ^LRO(69,"AA",LRCEX,LROA)=""
  1.  Q RETURN