VBECRPT ;HOIFO/RLM - APIS TO RETURN BLOOD BANK DATA FOR LAB ;Jan 31, 2020@13:10:43
;;2.0;VBEC;**8**;Jun 05, 2015;Build 27
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Reference to GETS^DIQ is supported by ICR #2056
; Reference to $$GET1^DIQ supported by ICR #2052
; Reference to DD^%DT supported by ICR #10003
; Reference to FIND^DIC supported by ICR #2051
; Reference to GETWP^XPAR supported by ICR #2263
;
EN ;Add sections as they are finished.
S VBLINE=1,PATID="`"_DFN,PATNAM=$P(^DPT(DFN,0),"^"),PATDOB=$P(^DPT(DFN,0),"^",3) D HEADER,ABORH
I $E(ABORH,1,2)="1^" D INCRL(3) D G EXIT
. D GETWP^XPAR(.VBERR,"ALL","OR VBECS ERROR MESSAGE") F I=1:1 Q:'$D(VBERR(I,0)) S VBLINE(VBLINE)=" "_VBERR(I,0),VBLINE=VBLINE+1
D ABID,TRRX,AVUNIT,DFN,COMPREQ,TRAN ;COMPREQ must follow DFN
EXIT ;Set up to print and clean up.
K ^TMP("ORLRC",$J) D INCRL(4)
S VBA=0 F S VBA=$O(VBLINE(VBA)) Q:VBA="" S ^TMP("ORLRC",$J,VBA,0)=VBLINE(VBA)
K VBA,VBABID,VBABIDC,VBB,VBC,VBCM,VBCM1,VBCMO,VBD,VBDATA,VBDATE,VBDATI,VBDTNT,VBECERR,VBINST,VBLINE,VBLN,VBM,VBPLC,VBQ,VBREQBY,VBREQD,VBREQR,VBRSLT,VBRXTYP,VBSPCCLM,VBSPCCM,VBSPCCML,VBSPCL,VBT,VBTN,VBTR,VBTRRX,VBTXT,VBWNTD,VBX,VBY
Q
S VBLINE(VBLINE)=" ---- BLOOD BANK ----",VBLINE=VBLINE+1
Q
TEST ;Calls
N ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR,ERROR
D ABORH,ABID,TRRX,DFN,CPRS,TRAN
W !!!,"CROSSMATCHED UNITS: "
I $O(^TMP("VBDATA",$J,"CROSSMATCH",0)) D
. S ID=0 F S ID=$O(^TMP("VBDATA",$J,"CROSSMATCH",ID)) Q:'ID W !?2,^(ID)
K ^TMP("VBDATA",$J),^TMP("TRRX",$J),^TMP("TRAN",$J)
Q
OEAPI ;Call to OEAPI^VBECA3
N DIV,ORSTN,ERROR,ORVB
S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3)
D OEAPI^VBECA3(.ORVB,+ORVP,ORSTN)
I $O(ORVB(0)) D
. W !!!,"Array returned from OEAPI^VBECA3 API in ORVB():",!
K ^TMP("OR",$J),^TMP("VBECRPC",$J),^TMP("VBECS_XML_RES",$J),^TMP("VBEC_OE_DATA",$J)
Q
ABORH ;Call to ABORH^VBECA1 for ABO/Rh - DBIA 3181
S ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB) Q:ABORH["1^"
D INCRL(3) ;F I=1:1:3 S VBLINE(VBLINE)="",VBLINE=VBLINE+1
S VBLINE(VBLINE)="ABO/RH: " I ABORH=""!(ABORH=" ") S VBLINE(VBLINE)=" No ABO/Rh results.",VBLINE=VBLINE+1 Q
S:ABO="I " ABO="Inconclusive "
S VBLINE(VBLINE)=VBLINE(VBLINE)_$G(ABO)_" "_$S(RH="P":"Positive",RH="N":"Negative",RH="I":"Inconclusive",1:""),VBLINE=VBLINE+1
Q
ABID ;Call to ABID^VBECA1 for Antibodies Identified - DBIA 3181, 3184
D ABID^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
D INCRL(3)
S VBLINE(VBLINE)="ANTIBODIES IDENTIFIED: ",VBLINE=VBLINE+1
I '$O(ORARR("ABID","")) D INCRL(1) S VBLINE(VBLINE)=" No Antibody results.",VBLINE=VBLINE+1 G TREQ
S ID=0,VBABID=" " F S ID=$O(ORARR("ABID",ID)) Q:'ID S VBABID=VBABID_$S(VBABID=" ":"",1:", ")_ORARR("ABID",ID) D
. S ID1=0 F S ID1=$O(ORARR("ABID",ID,ID1)) Q:'ID1 S VBABIDC(ID1)=ORARR("ABID",ID,ID1)
S VBLINE(VBLINE)=" "_VBABID,VBLINE=VBLINE+1
S VBLINE(VBLINE)=" COMMENT:",VBLINE=VBLINE+1
;S ID1=0 F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=" "_VBABIDC(ID1),VBLINE=VBLINE+1
S ID1=0 S VBLINE(VBLINE)=" " F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
S VBLINE=VBLINE+1
K VBABID,VBABIDC
TREQ ;W !!,"Transfusion Requirements"
D INCRL(2) S VBLINE(VBLINE)="TRANSFUSION REQUIREMENTS",VBLINE=VBLINE+1
I '$O(ORARR("ABID","TR","")) D INCRL(1) S VBLINE(VBLINE)=" No Transfusion Requirements.",VBLINE=VBLINE+1 Q
S ID=0,VBABID=" " F S ID=$O(ORARR("ABID","TR",ID)) Q:'ID S VBABID=VBABID_$S(VBABID=" ":"",1:", ")_ORARR("ABID","TR",ID) D
. S ID1=0 F S ID1=$O(ORARR("ABID","TR",ID,ID1)) Q:'ID1 S VBABIDC(ID1)=ORARR("ABID","TR",ID,ID1)
S VBLINE(VBLINE)=" "_VBABID,VBLINE=VBLINE+1
S VBLINE(VBLINE)=" COMMENT:",VBLINE=VBLINE+1
S ID1=0 S VBLINE(VBLINE)=" " F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
S VBLINE=VBLINE+1
Q
DFN ;Call to DFN^VBECA3A - DBIA 3879
K ^TMP("VBDATA",$J)
D DFN^VBECA1B(DFN)
D INCRL(2) K ^TMP("VBRPTDTA",$J) S VBSPCCML=1,$P(VBX," ",256)=""
S VBLINE(VBLINE)="DIAGNOSTIC TESTS",VBLINE=VBLINE+1
I '$O(^TMP("VBDATA",$J,"SPECIMEN","")) D INCRL(1) S VBLINE(VBLINE)=" No results.",VBLINE=VBLINE+1 Q
S (ID,ID1,ID2)="" F S ID=$O(^TMP("VBDATA",$J,"SPECIMEN",ID)) Q:'ID D
. S VBSPCID=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",9)
. S VBDATE=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",8) D VBDAT S VBSPDT=VBDATE,VBDPDTI=VBDATI
. S VBDPDTI=VBDATI_" "_VBSPCID
. S VBSPCID=VBSPCID_$E(VBX,$L(VBX),12)
. S VBDATE=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",10) D VBDAT1 S VBCLDT=VBDATE,VBCLDTI=VBDATI
. S VBINST=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",2) D INSTLK
. S VBTN=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",5)
. S VBPLC=$S(VBTN="ABO Interp":2,VBTN="Rh Interp":3,VBTN="Antibody Screen Interp":4,VBTN="DAT Poly AHG":5,VBTN="DAT Poly Interp":6,VBTN="DAT IgG AHG":7,VBTN="DAT IgG Interp":8,VBTN="DAT Comp AHG":9,VBTN="DAT Comp Interp":10,1:0)
. S:'$D(^TMP("VBRPTDTA",$J,VBDPDTI)) ^TMP("VBRPTDTA",$J,VBDPDTI)=VBSPDT_"^^^^^^^^^^"_VBINST_"^"_VBCLDT_"^"_VBSPCID
. S VBRSLT=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",7) I VBRSLT="No Agglutination" S VBRSLT=0
. I VBPLC S $P(^TMP("VBRPTDTA",$J,VBDPDTI),"^",VBPLC)=VBRSLT D
. . F VBLN=1:1:3 I $G(^TMP("VBDATA",$J,"SPECIMEN",ID,VBLN))]"" S ^TMP("VBRPTDTA",$J,VBDPDTI,$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",5),VBLN)="Comment ("_$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",5)_"): "_^TMP("VBDATA",$J,"SPECIMEN",ID,VBLN)
. . F VBLN=4:1:6 S VBSPCCM=$G(^TMP("VBDATA",$J,"SPECIMEN",ID,VBLN)) I VBSPCCM]"" D
. . . I '$D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S ^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,VBSPCCML)="" S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCML)="",VBSPCCML=VBSPCCML+1 Q
. . . I $D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S VBSPCCLM=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,"")) S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCLM)=""
. . I $G(^TMP("VBDATA",$J,"SPECIMEN",ID,7))]"" D
. . . S VBSPCCM=^TMP("VBDATA",$J,"SPECIMEN",ID,7)
. . . I '$D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S ^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,VBSPCCML)="" S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCML)="",VBSPCCML=VBSPCCML+1 Q
. . . I $D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S VBSPCCLM=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,"")) S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCLM)=""
S VBLINE(VBLINE)="",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" |------- DAT -------|",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" |Poly| |IgG| |Comp|",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" Collection Date UID Test Date/Time ABO Rh ABS Intrp Intrp Intrp Division",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" --------------- --- -------------- ------ --- ----- ----- ----- --------",VBLINE=VBLINE+1
S VBDATI="" F S VBDATI=$O(^TMP("VBRPTDTA",$J,VBDATI)) Q:'VBDATI S VBDATA=^TMP("VBRPTDTA",$J,VBDATI) D ;
. D INCRL(1) S VBLINE(VBLINE)=""
. I $O(^TMP("VBRPTDTA",$J,VBDATI,"VBSPCL",0)) S VBSPCL=0 S VBLINE(VBLINE)="(" D
. . F S VBSPCL=$O(^TMP("VBRPTDTA",$J,VBDATI,"VBSPCL",VBSPCL)) Q:'VBSPCL S VBLINE(VBLINE)=VBLINE(VBLINE)_VBSPCL S VBLINE(VBLINE)=VBLINE(VBLINE)_$S($O(^TMP("VBRPTDTA",$J,VBDATI,"VBSPCL",VBSPCL)):",",1:")")
. S VBLINE(VBLINE)=VBLINE(VBLINE)_$E(" ",1,(7-$L(VBLINE(VBLINE))))
. S VBLINE(VBLINE)=VBLINE(VBLINE)_$P(VBDATA,"^",12)_" "_$P(VBDATA,"^",13)_" "_$P(VBDATA,"^")_" "_$P(VBDATA,"^",2)_" "_$E(VBX,1,(3-$L($P(VBDATA,"^",2))))_$P(VBDATA,"^",3)_$E(VBX,1,(5-$L($P(VBDATA,"^",3)))) D
. . S VBLINE(VBLINE)=VBLINE(VBLINE)_$P(VBDATA,"^",4)_$E(VBX,1,(7-$L($P(VBDATA,"^",4))))_$P(VBDATA,"^",6)_$E(VBX,1,(8-$L($P(VBDATA,"^",6))))_$P(VBDATA,"^",8)_$E(VBX,1,(7-$L($P(VBDATA,"^",8))))
. . S VBLINE(VBLINE)=VBLINE(VBLINE)_$P(VBDATA,"^",10)_$E(VBX,1,(7-$L($P(VBDATA,"^",10))))_$P(VBDATA,"^",11),VBLINE=VBLINE+1
. S VBCM="" F S VBCM=$O(^TMP("VBRPTDTA",$J,VBDATI,VBCM)) Q:VBCM="VBSPCL"!(VBCM="") F I=1:1 Q:'$D(^TMP("VBRPTDTA",$J,VBDATI,VBCM,I)) S VBLINE(VBLINE)=" "_^TMP("VBRPTDTA",$J,VBDATI,VBCM,I),VBLINE=VBLINE+1
S (VBCM,VBCM1)="" F S VBCM=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBCM)) Q:VBCM="" F S VBCM1=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBCM,VBCM1)) Q:'VBCM1 S VBCMO(VBCM1)=VBCM
I $O(VBCMO(0))="" Q
D INCRL(2) S VBLINE(VBLINE)=" ----- STANDARD COMMENTS FOR DIAGNOSTIC TESTS ABOVE -----",VBLINE=VBLINE+1
S VBI="" F S VBI=$O(VBCMO(VBI)) Q:VBI="" S VBLINE(VBLINE)="("_VBI_") "_VBCMO(VBI),VBLINE=VBLINE+1
Q
VBDAT ;CONVERT DATE 3200114.16132
S VBDATI=9999999-VBDATE
VBDAT1 S Y=VBDATE D DD^%DT S VBT=$P($P(Y,"@",2),":",1,2)
S VBY=(($E(VBDATE,1)*100)+1700)+$E(VBDATE,2,3),VBM=$E(VBDATE,4,5),VBD=$E(VBDATE,6,7)
S VBDATE=VBM_"/"_VBD_"/"_VBY_"@"_VBT
S VBDTNT=VBM_"/"_VBD_"/"_VBY
Q
AVUNIT ;Available Units
D AVUNIT^VBECA4(DFN,"VBA"),INCRL(3)
S VBLINE(VBLINE)="AVAILABLE/ISSUED UNITS:",VBLINE=VBLINE+1
I $O(^TMP("VBA",$J,""))="" D INCRL(1) S VBLINE(VBLINE)=" No Available/Issued Units.",VBLINE=VBLINE+1 Q
S VBA=$G(^TMP("VBA",$J,0)),$P(VBX," ",256)=""
Q:VBA=""
S VBLINE(VBLINE)=" Date Assigned Issue Date Unit ID Product Code Product Name ABO/Rh Exp. Date Location Division",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" ------------- ---------- ------- ------------ --------- ------ --------- -------- --------",VBLINE=VBLINE+1
S (VBA,VBB)=0 F S VBA=$O(^TMP("VBA",$J,VBA)) Q:VBA="" S VBB=^TMP("VBA",$J,VBA) D
. S VBDATE=9999999-VBA D VBDAT1 S VBDTA=VBDATE
. S VBC=^TMP("VBA",$J,VBA)
. S VBDATE=$P(VBC,"^",14) I VBDATE]"" D VBDAT1 S VBDST=VBDATE
. I $P(VBC,"^",14)="" S VBDST=" "
. S VBABORH=$J($P(VBC,"^",6),2)_" "_$J($P(VBC,"^",7),3)_" ",VBABORH=$E(VBABORH,1,14)
. S VBUNIT=$P(VBC,"^",3),VBUNIT=VBUNIT_$E(VBX,$L(VBUNIT),13)
. S VBPRID=$P(VBC,"^",11),VBPRID=VBPRID_$E(VBX,$L(VBPRID),9)
. S VBLOC=$E($P(VBC,"^",10),1,10),VBLOC=VBLOC_$E(VBX,1,(11-$L(VBLOC)))
. S VBLINE(VBLINE)=" "_VBDTA_" "_VBDST_" "_VBUNIT_" "_VBPRID_" "_$E($P(VBC,"^",13),1,57)_$E(VBX,1,(58-$L($P(VBC,"^",13))))_" "
. S VBLINE(VBLINE)=VBLINE(VBLINE)_VBABORH_" "_$P(VBC,"^",2)_" "_VBLOC_$P(VBC,"^",9),VBLINE=VBLINE+1
Q
INSTLK ;Lookup Institution
D FIND^DIC(4,,.01,"MX",VBINST,,"D",,,"VBINST1","VBERR")
S VBINST=$G(VBINST1("DILIST","ID",1,.01))
Q
CPRS ;Call to CPRS^VBECA3B - DBIA 3880
N ID,ID1,ID2,ERROR
K ^TMP("BBD",$J)
D CPRS^VBECA3B
W !!!,"Specimen: "
I $O(^TMP("BBD",$J,"SPECIMEN",0)) D
. S ID=0 F S ID=$O(^TMP("BBD",$J,"SPECIMEN",ID)) Q:'ID W !?2,^(ID) D
.. S ID1=0 F S ID1=$O(^TMP("BBD",$J,"SPECIMEN",ID,ID1)) Q:'ID1 W:$D(^(ID1))#2 !,"."_^(ID1) D
... S ID2=0 F S ID2=$O(^TMP("BBD",$J,"SPECIMEN",ID,ID1,ID2)) Q:'ID2 W:$D(^(ID2))#2 !,".."_^(ID2)
Q
COMPREQ ;Component Requests
D INCRL(3)
S VBLINE(VBLINE)="COMPONENT REQUESTS:",VBLINE=VBLINE+1
I '$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",0)) D INCRL(1) S VBLINE(VBLINE)=" No Component Requests.",VBLINE=VBLINE+1 Q
S VBLINE(VBLINE)=" Component Type Qty Request date Date wanted Requestor By",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" -------------- --- ------------ ----------- --------- --",VBLINE=VBLINE+1
I $O(^TMP("VBDATA",$J,"COMPONENT REQUEST",0)) D
. S ID=0 F S ID=$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",ID)) Q:'ID S VBA=^(ID) D
. . S VBDATE=$P(VBA,"^",3) D VBDAT1 S VBREQD=VBDATE S VBDATE=$P(VBA,"^",4) D VBDAT1 S VBWNTD=VBDTNT
. . S VBREQR=$$GET1^DIQ(200,$P(VBA,"^",5),1),VBREQBY=$$GET1^DIQ(200,$P(VBA,"^",6),1),VBREQR=$E(VBREQR_" ",1,5)
. . S VBLINE(VBLINE)=" "_$E($P(VBA,"^"),1,20)_$E(VBX,$L($P(VBA,"^")),20)_$P(VBA,"^",2)_$E(VBX,$L($P(VBA,"^",2)),3)_VBREQD_" "_VBWNTD_" "_VBREQR_" "_VBREQBY,VBLINE=VBLINE+1
Q
TRAN ;Call to TRAN^VBECA4 for Tranfused Units - DBIA 3176
K ^TMP("TRAN",$J),^TMP("ZTRAN",$J)
D TRAN^VBECA4(+DFN,"TRAN")
S CNT=0 F ID="RBC","FFP","PLT","CRY","PLA","SER","GRA","WB" S CNT=CNT+1,ORAY(ID)=CNT
S ID=0 F S ID=$O(^TMP("TRAN",$J,ID)) Q:'ID S GMR=^(ID),COMP=$P(GMR,"^",2),COMP=$P(COMP,"\",2),COMP=$E($P(COMP,";"),1,3),COMPSEQ=$S($D(ORAY(COMP)):ORAY(COMP),1:99) D
. I '$D(^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ)) S ^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ)=GMR_"^"_1 Q
. S CNT=$P(^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ),"^",3),$P(^(COMPSEQ),"^",3)=CNT+1
D INCRL(3) S VBLINE(VBLINE)="TRANSFUSED UNITS",VBLINE=VBLINE+1,$P(VBX," ",256)=""
I '$O(^TMP("TRAN",$J,0)) D INCRL(1) S VBLINE(VBLINE)=" No Transfused Units.",VBLINE=VBLINE+1 Q
S VBLINE(VBLINE)=" Date Transfused Unit ID Product Code Product Name ABO/Rh",VBLINE=VBLINE+1
S VBLINE(VBLINE)=" --------------- ------- ------------ ------------ ------",VBLINE=VBLINE+1
S ID=0 F S ID=$O(^TMP("TRAN",$J,ID)) Q:'ID S VBA=^(ID),VBDATE=$P(VBA,"^") D VBDAT1 D
. S VBTR=$P(VBA,"^",2)
. S VBQ=$P(VBTR,"\"),VBQ=$J("("_VBQ_")",5)
. S VBT=$P(VBA,"^",7),VBT=VBT_$E(VBX,$L(VBT),57)
. S VBABORH=$P(VBA,"^",3)_" "_$P(VBA,"^",4)_" ",VBABORH=$E(VBABORH,1,14)
. S VBUNIT=$P(VBA,"^",6),VBUNIT=VBUNIT_$E(VBX,$L(VBUNIT),14)
. S VBPROD=$P(VBA,"^",5),VBPROD=VBPROD_$E(VBX,$L(VBPROD),15)
. S VBLINE(VBLINE)=" "_VBDTNT_" "_VBUNIT_VBPROD_VBT_VBABORH,VBLINE=VBLINE+1
. ;S VBLINE(VBLINE)=" "_VBDTNT_" ("_VBQ_")"_$E(" ",$L(VBQ),4)_$P(VBT,";"),VBLINE=VBLINE+1
;S VBTXT=1,VBA="A" F S VBA=$O(^TMP("TRAN",$J,VBA)) Q:VBA="" S VBLINE(VBLINE)=$S(VBTXT:" Blood Product Key: ",1:" ")_VBA_" = "_^(VBA),VBLINE=VBLINE+1,VBTXT=0
Q
TRRX ;Call to TRRX^VBECA1 for Transfusion Reactions - DBIA 3181, 3187
D TRRX^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
D INCRL(3) S VBLINE(VBLINE)="TRANSFUSION REACTIONS: ",VBLINE=VBLINE+1 S $P(VBX," ",256)=""
I '$O(ORARR("TRRX",0)) D INCRL(1) S VBLINE(VBLINE)=" No Transfusion Reactions.",VBLINE=VBLINE+1 Q
I $O(ORARR("TRRX",0)) D
. S ID=0 F S ID=$O(ORARR("TRRX",ID)) Q:'ID D ;W !?2,ORARR("TRRX",ID)
. . S VBRXTYP=$P(ORARR("TRRX",ID),"^",2)
. . S Y=$P(ORARR("TRRX",ID),"^") D DD^%DT Q:Y="" I VBRXTYP="" S VBRXTYP="Unknown"
. . S VBTRRX(VBRXTYP,ID)=Y_"^"_$S($P(ORARR("TRRX",ID),"^",3)]"":$P(ORARR("TRRX",ID),"^",3),1:"None")_"^"_$S($P(ORARR("TRRX",ID),"^",4)]"":$P(ORARR("TRRX",ID),"^",4),1:" None")
. . S ID1="" F S ID1=$O(ORARR("TRRX",ID,ID1)) Q:'ID1 S VBTRRX(VBRXTYP,ID,ID1)=ORARR("TRRX",ID,ID1)
S (ID,ID1)="" F S ID=$O(VBTRRX(ID)) Q:ID="" S VBLINE(VBLINE)=" Type: "_ID,VBLINE=VBLINE+1 D TRRXHDR D
. F S ID1=$O(VBTRRX(ID,ID1)) Q:'ID1 S VBLINE(VBLINE)=" "_$P(VBTRRX(ID,ID1),"^")_$E(VBX,$L($P(VBTRRX(ID,ID1),"^")),26)_$P(VBTRRX(ID,ID1),"^",2)_$E(VBX,$L($P(VBTRRX(ID,ID1),"^")),27)_$P(VBTRRX(ID,ID1),"^",3),VBLINE=VBLINE+1 D
. . S:$O(VBTRRX(ID,ID1,"")) VBLINE(VBLINE)=" Comment: ",VBLINE=VBLINE+1
. . S ID2="" F S ID2=$O(VBTRRX(ID,ID1,ID2)) Q:'ID2 S VBLINE(VBLINE)=" "_VBTRRX(ID,ID1,ID2),VBLINE=VBLINE+1 ;W !?5,VBTRRX(ID,ID1,ID2)
Q
TRRXHDR ;Transfusion Reaction Header
S VBLINE(VBLINE)=" Date/Time Unit Id Component",VBLINE=VBLINE+1,VBLINE(VBLINE)=" --------- ------- ---------",VBLINE=VBLINE+1
Q
PARSE ;Parse Record
N GMI,X
S TD=$$FMTE^XLFDT(+GMR)
S GMA(1)=$P(GMR,U,2),BPN=$L(GMA(1),";")
I $P(GMA(1),";",BPN)="" S BPN=BPN-1
F GMI=2:1:BPN S GMA(GMI)="("_$P($P(GMA(1),";",GMI),"\")_") "_$P($P(GMA(1),";",GMI),"\",2)
S GMA(1)="("_$P($P(GMA(1),";",1),"\")_") "_$P($P(GMA(1),";",1),"\",2)
Q
WRT ; Writes the Transfusion Record for each day
N GML,GMI1,GMI2,GMM,GMJ
S GMM=$S(BPN#4:1,1:0),GML=BPN\4+GMM
W TD
F GMI1=1:1:GML D
. F GMI2=1:1:($S((GMI1=GML)&(BPN#4):BPN#4,1:4)) D
.. S GMJ=((GMI1-1)*4)+GMI2
.. W ?(((GMI2-1)*15)+13),GMA(GMJ)
.. I $S(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0) W !
Q
INCRL(I) ;Increment line
F I=1:1:I S VBLINE(VBLINE)="",VBLINE=VBLINE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPT 16344 printed Oct 16, 2024@18:44:53 Page 2
VBECRPT ;HOIFO/RLM - APIS TO RETURN BLOOD BANK DATA FOR LAB ;Jan 31, 2020@13:10:43
+1 ;;2.0;VBEC;**8**;Jun 05, 2015;Build 27
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+8 ; Reference to GETS^DIQ is supported by ICR #2056
+9 ; Reference to $$GET1^DIQ supported by ICR #2052
+10 ; Reference to DD^%DT supported by ICR #10003
+11 ; Reference to FIND^DIC supported by ICR #2051
+12 ; Reference to GETWP^XPAR supported by ICR #2263
+13 ;
EN ;Add sections as they are finished.
+1 SET VBLINE=1
SET PATID="`"_DFN
SET PATNAM=$PIECE(^DPT(DFN,0),"^")
SET PATDOB=$PIECE(^DPT(DFN,0),"^",3)
DO HEADER
DO ABORH
+2 IF $EXTRACT(ABORH,1,2)="1^"
DO INCRL(3)
Begin DoDot:1
+3 DO GETWP^XPAR(.VBERR,"ALL","OR VBECS ERROR MESSAGE")
FOR I=1:1
if '$DATA(VBERR(I,0))
QUIT
SET VBLINE(VBLINE)=" "_VBERR(I,0)
SET VBLINE=VBLINE+1
End DoDot:1
GOTO EXIT
+4 ;COMPREQ must follow DFN
DO ABID
DO TRRX
DO AVUNIT
DO DFN
DO COMPREQ
DO TRAN
EXIT ;Set up to print and clean up.
+1 KILL ^TMP("ORLRC",$JOB)
DO INCRL(4)
+2 SET VBA=0
FOR
SET VBA=$ORDER(VBLINE(VBA))
if VBA=""
QUIT
SET ^TMP("ORLRC",$JOB,VBA,0)=VBLINE(VBA)
+3 KILL VBA,VBABID,VBABIDC,VBB,VBC,VBCM,VBCM1,VBCMO,VBD,VBDATA,VBDATE,VBDATI,VBDTNT,VBECERR,VBINST,VBLINE,VBLN,VBM,VBPLC,VBQ,VBREQBY,VBREQD,VBREQR,VBRSLT,VBRXTYP,VBSPCCLM,VBSPCCM,VBSPCCML,VBSPCL,VBT,VBTN,VBTR,VBTRRX,VBTXT,VBWNTD,VBX,VBY
+4 QUIT
+1 SET VBLINE(VBLINE)=" ---- BLOOD BANK ----"
SET VBLINE=VBLINE+1
+2 QUIT
TEST ;Calls
+1 NEW ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR,ERROR
+2 DO ABORH
DO ABID
DO TRRX
DO DFN
DO CPRS
DO TRAN
+3 WRITE !!!,"CROSSMATCHED UNITS: "
+4 IF $ORDER(^TMP("VBDATA",$JOB,"CROSSMATCH",0))
Begin DoDot:1
+5 SET ID=0
FOR
SET ID=$ORDER(^TMP("VBDATA",$JOB,"CROSSMATCH",ID))
if 'ID
QUIT
WRITE !?2,^(ID)
End DoDot:1
+6 KILL ^TMP("VBDATA",$JOB),^TMP("TRRX",$JOB),^TMP("TRAN",$JOB)
+7 QUIT
OEAPI ;Call to OEAPI^VBECA3
+1 NEW DIV,ORSTN,ERROR,ORVB
+2 SET DIV=+$PIECE($GET(^SC(+$GET(ORL),0)),U,15)
SET ORSTN=$PIECE($$SITE^VASITE(DT,DIV),U,3)
+3 DO OEAPI^VBECA3(.ORVB,+ORVP,ORSTN)
+4 IF $ORDER(ORVB(0))
Begin DoDot:1
+5 WRITE !!!,"Array returned from OEAPI^VBECA3 API in ORVB():",!
End DoDot:1
+6 KILL ^TMP("OR",$JOB),^TMP("VBECRPC",$JOB),^TMP("VBECS_XML_RES",$JOB),^TMP("VBEC_OE_DATA",$JOB)
+7 QUIT
ABORH ;Call to ABORH^VBECA1 for ABO/Rh - DBIA 3181
+1 SET ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB)
if ABORH["1^"
QUIT
+2 ;F I=1:1:3 S VBLINE(VBLINE)="",VBLINE=VBLINE+1
DO INCRL(3)
+3 SET VBLINE(VBLINE)="ABO/RH: "
IF ABORH=""!(ABORH=" ")
SET VBLINE(VBLINE)=" No ABO/Rh results."
SET VBLINE=VBLINE+1
QUIT
+4 if ABO="I "
SET ABO="Inconclusive "
+5 SET VBLINE(VBLINE)=VBLINE(VBLINE)_$GET(ABO)_" "_$SELECT(RH="P":"Positive",RH="N":"Negative",RH="I":"Inconclusive",1:"")
SET VBLINE=VBLINE+1
+6 QUIT
ABID ;Call to ABID^VBECA1 for Antibodies Identified - DBIA 3181, 3184
+1 DO ABID^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
+2 DO INCRL(3)
+3 SET VBLINE(VBLINE)="ANTIBODIES IDENTIFIED: "
SET VBLINE=VBLINE+1
+4 IF '$ORDER(ORARR("ABID",""))
DO INCRL(1)
SET VBLINE(VBLINE)=" No Antibody results."
SET VBLINE=VBLINE+1
GOTO TREQ
+5 SET ID=0
SET VBABID=" "
FOR
SET ID=$ORDER(ORARR("ABID",ID))
if 'ID
QUIT
SET VBABID=VBABID_$SELECT(VBABID=" ":"",1:", ")_ORARR("ABID",ID)
Begin DoDot:1
+6 SET ID1=0
FOR
SET ID1=$ORDER(ORARR("ABID",ID,ID1))
if 'ID1
QUIT
SET VBABIDC(ID1)=ORARR("ABID",ID,ID1)
End DoDot:1
+7 SET VBLINE(VBLINE)=" "_VBABID
SET VBLINE=VBLINE+1
+8 SET VBLINE(VBLINE)=" COMMENT:"
SET VBLINE=VBLINE+1
+9 ;S ID1=0 F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=" "_VBABIDC(ID1),VBLINE=VBLINE+1
+10 SET ID1=0
SET VBLINE(VBLINE)=" "
FOR
SET ID1=$ORDER(VBABIDC(ID1))
if ID1=""
QUIT
SET VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
+11 SET VBLINE=VBLINE+1
+12 KILL VBABID,VBABIDC
TREQ ;W !!,"Transfusion Requirements"
+1 DO INCRL(2)
SET VBLINE(VBLINE)="TRANSFUSION REQUIREMENTS"
SET VBLINE=VBLINE+1
+2 IF '$ORDER(ORARR("ABID","TR",""))
DO INCRL(1)
SET VBLINE(VBLINE)=" No Transfusion Requirements."
SET VBLINE=VBLINE+1
QUIT
+3 SET ID=0
SET VBABID=" "
FOR
SET ID=$ORDER(ORARR("ABID","TR",ID))
if 'ID
QUIT
SET VBABID=VBABID_$SELECT(VBABID=" ":"",1:", ")_ORARR("ABID","TR",ID)
Begin DoDot:1
+4 SET ID1=0
FOR
SET ID1=$ORDER(ORARR("ABID","TR",ID,ID1))
if 'ID1
QUIT
SET VBABIDC(ID1)=ORARR("ABID","TR",ID,ID1)
End DoDot:1
+5 SET VBLINE(VBLINE)=" "_VBABID
SET VBLINE=VBLINE+1
+6 SET VBLINE(VBLINE)=" COMMENT:"
SET VBLINE=VBLINE+1
+7 SET ID1=0
SET VBLINE(VBLINE)=" "
FOR
SET ID1=$ORDER(VBABIDC(ID1))
if ID1=""
QUIT
SET VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
+8 SET VBLINE=VBLINE+1
+9 QUIT
DFN ;Call to DFN^VBECA3A - DBIA 3879
+1 KILL ^TMP("VBDATA",$JOB)
+2 DO DFN^VBECA1B(DFN)
+3 DO INCRL(2)
KILL ^TMP("VBRPTDTA",$JOB)
SET VBSPCCML=1
SET $PIECE(VBX," ",256)=""
+4 SET VBLINE(VBLINE)="DIAGNOSTIC TESTS"
SET VBLINE=VBLINE+1
+5 IF '$ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",""))
DO INCRL(1)
SET VBLINE(VBLINE)=" No results."
SET VBLINE=VBLINE+1
QUIT
+6 SET (ID,ID1,ID2)=""
FOR
SET ID=$ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",ID))
if 'ID
QUIT
Begin DoDot:1
+7 SET VBSPCID=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",9)
+8 SET VBDATE=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",8)
DO VBDAT
SET VBSPDT=VBDATE
SET VBDPDTI=VBDATI
+9 SET VBDPDTI=VBDATI_" "_VBSPCID
+10 SET VBSPCID=VBSPCID_$EXTRACT(VBX,$LENGTH(VBX),12)
+11 SET VBDATE=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",10)
DO VBDAT1
SET VBCLDT=VBDATE
SET VBCLDTI=VBDATI
+12 SET VBINST=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",2)
DO INSTLK
+13 SET VBTN=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",5)
+14 SET VBPLC=$SELECT(VBTN="ABO Interp":2,VBTN="Rh Interp":3,VBTN="Antibody Screen Interp":4,VBTN="DAT Poly AHG":5,VBTN="DAT Poly Interp":6,VBTN="DAT IgG AHG":7,VBTN="DAT IgG Interp":8,VBTN="DAT Comp AHG":9,VBTN="DAT Comp Interp":10,1:0)
+15 if '$DATA(^TMP("VBRPTDTA",$JOB,VBDPDTI))
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI)=VBSPDT_"^^^^^^^^^^"_VBINST_"^"_VBCLDT_"^"_VBSPCID
+16 SET VBRSLT=$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",7)
IF VBRSLT="No Agglutination"
SET VBRSLT=0
+17 IF VBPLC
SET $PIECE(^TMP("VBRPTDTA",$JOB,VBDPDTI),"^",VBPLC)=VBRSLT
Begin DoDot:2
+18 FOR VBLN=1:1:3
IF $GET(^TMP("VBDATA",$JOB,"SPECIMEN",ID,VBLN))]""
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI,$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",5),VBLN)="Comment ("_$PIECE(^TMP("VBDATA",$JOB,"SPECIMEN",ID),"^",5)_"): "_^TMP("VBDATA",$JOB,"SPECIMEN",ID,VBLN)
+19 FOR VBLN=4:1:6
SET VBSPCCM=$GET(^TMP("VBDATA",$JOB,"SPECIMEN",ID,VBLN))
IF VBSPCCM]""
Begin DoDot:3
+20 IF '$DATA(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM))
SET ^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM,VBSPCCML)=""
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI,"VBSPCL",VBSPCCML)=""
SET VBSPCCML=VBSPCCML+1
QUIT
+21 IF $DATA(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM))
SET VBSPCCLM=$ORDER(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM,""))
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI,"VBSPCL",VBSPCCLM)=""
End DoDot:3
+22 IF $GET(^TMP("VBDATA",$JOB,"SPECIMEN",ID,7))]""
Begin DoDot:3
+23 SET VBSPCCM=^TMP("VBDATA",$JOB,"SPECIMEN",ID,7)
+24 IF '$DATA(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM))
SET ^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM,VBSPCCML)=""
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI,"VBSPCL",VBSPCCML)=""
SET VBSPCCML=VBSPCCML+1
QUIT
+25 IF $DATA(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM))
SET VBSPCCLM=$ORDER(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBSPCCM,""))
SET ^TMP("VBRPTDTA",$JOB,VBDPDTI,"VBSPCL",VBSPCCLM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+26 SET VBLINE(VBLINE)=""
SET VBLINE=VBLINE+1
+27 SET VBLINE(VBLINE)=" |------- DAT -------|"
SET VBLINE=VBLINE+1
+28 SET VBLINE(VBLINE)=" |Poly| |IgG| |Comp|"
SET VBLINE=VBLINE+1
+29 SET VBLINE(VBLINE)=" Collection Date UID Test Date/Time ABO Rh ABS Intrp Intrp Intrp Division"
SET VBLINE=VBLINE+1
+30 SET VBLINE(VBLINE)=" --------------- --- -------------- ------ --- ----- ----- ----- --------"
SET VBLINE=VBLINE+1
+31 ;
SET VBDATI=""
FOR
SET VBDATI=$ORDER(^TMP("VBRPTDTA",$JOB,VBDATI))
if 'VBDATI
QUIT
SET VBDATA=^TMP("VBRPTDTA",$JOB,VBDATI)
Begin DoDot:1
+32 DO INCRL(1)
SET VBLINE(VBLINE)=""
+33 IF $ORDER(^TMP("VBRPTDTA",$JOB,VBDATI,"VBSPCL",0))
SET VBSPCL=0
SET VBLINE(VBLINE)="("
Begin DoDot:2
+34 FOR
SET VBSPCL=$ORDER(^TMP("VBRPTDTA",$JOB,VBDATI,"VBSPCL",VBSPCL))
if 'VBSPCL
QUIT
SET VBLINE(VBLINE)=VBLINE(VBLINE)_VBSPCL
SET VBLINE(VBLINE)=VBLINE(VBLINE)_$SELECT($ORDER(^TMP("VBRPTDTA",$JOB,VBDATI,"VBSPCL",VBSPCL)):",",1:")")
End DoDot:2
+35 SET VBLINE(VBLINE)=VBLINE(VBLINE)_$EXTRACT(" ",1,(7-$LENGTH(VBLINE(VBLINE))))
+36 SET VBLINE(VBLINE)=VBLINE(VBLINE)_$PIECE(VBDATA,"^",12)_" "_$PIECE(VBDATA,"^",13)_" "_$PIECE(VBDATA,"^")_" "_$PIECE(VBDATA,"^",2)_" "_$EXTRACT(VBX,1,(3-$LENGTH($PIECE(VBDATA,"^",2))))_$PIECE(VBDATA,"^",3)_$EXTRACT(VBX,1,(5-$LENGTH(...
... $PIECE(VBDATA,"^",3))))
Begin DoDot:2
+37 SET VBLINE(VBLINE)=VBLINE(VBLINE)_$PIECE(VBDATA,"^",4)_$EXTRACT(VBX,1,(7-$LENGTH($PIECE(VBDATA,"^",4))))_$PIECE(VBDATA,"^",6)_$EXTRACT(VBX,1,(8-$LENGTH($PIECE(VBDATA,"^",6))))_$PIECE(VBDATA,"^",8)_$EXTRACT(VBX,1,(7-$LENGTH($PIECE(VB
DATA,"^",8))))
+38 SET VBLINE(VBLINE)=VBLINE(VBLINE)_$PIECE(VBDATA,"^",10)_$EXTRACT(VBX,1,(7-$LENGTH($PIECE(VBDATA,"^",10))))_$PIECE(VBDATA,"^",11)
SET VBLINE=VBLINE+1
End DoDot:2
+39 SET VBCM=""
FOR
SET VBCM=$ORDER(^TMP("VBRPTDTA",$JOB,VBDATI,VBCM))
if VBCM="VBSPCL"!(VBCM="")
QUIT
FOR I=1:1
if '$DATA(^TMP("VBRPTDTA",$JOB,VBDATI,VBCM,I))
QUIT
SET VBLINE(VBLINE)=" "_^TMP("VBRPTDTA",$JOB,VBDATI,VBCM,I)
SET VBLINE=VBLINE+1
End DoDot:1
+40 SET (VBCM,VBCM1)=""
FOR
SET VBCM=$ORDER(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBCM))
if VBCM=""
QUIT
FOR
SET VBCM1=$ORDER(^TMP("VBRPTDTA",$JOB,"VBSPCCM",VBCM,VBCM1))
if 'VBCM1
QUIT
SET VBCMO(VBCM1)=VBCM
+41 IF $ORDER(VBCMO(0))=""
QUIT
+42 DO INCRL(2)
SET VBLINE(VBLINE)=" ----- STANDARD COMMENTS FOR DIAGNOSTIC TESTS ABOVE -----"
SET VBLINE=VBLINE+1
+43 SET VBI=""
FOR
SET VBI=$ORDER(VBCMO(VBI))
if VBI=""
QUIT
SET VBLINE(VBLINE)="("_VBI_") "_VBCMO(VBI)
SET VBLINE=VBLINE+1
+44 QUIT
VBDAT ;CONVERT DATE 3200114.16132
+1 SET VBDATI=9999999-VBDATE
VBDAT1 SET Y=VBDATE
DO DD^%DT
SET VBT=$PIECE($PIECE(Y,"@",2),":",1,2)
+1 SET VBY=(($EXTRACT(VBDATE,1)*100)+1700)+$EXTRACT(VBDATE,2,3)
SET VBM=$EXTRACT(VBDATE,4,5)
SET VBD=$EXTRACT(VBDATE,6,7)
+2 SET VBDATE=VBM_"/"_VBD_"/"_VBY_"@"_VBT
+3 SET VBDTNT=VBM_"/"_VBD_"/"_VBY
+4 QUIT
AVUNIT ;Available Units
+1 DO AVUNIT^VBECA4(DFN,"VBA")
DO INCRL(3)
+2 SET VBLINE(VBLINE)="AVAILABLE/ISSUED UNITS:"
SET VBLINE=VBLINE+1
+3 IF $ORDER(^TMP("VBA",$JOB,""))=""
DO INCRL(1)
SET VBLINE(VBLINE)=" No Available/Issued Units."
SET VBLINE=VBLINE+1
QUIT
+4 SET VBA=$GET(^TMP("VBA",$JOB,0))
SET $PIECE(VBX," ",256)=""
+5 if VBA=""
QUIT
+6 SET VBLINE(VBLINE)=" Date Assigned Issue Date Unit ID Product Code Product Name ABO/Rh Exp. Date Location Division"
SET VBLINE=VBLINE+1
+7 SET VBLINE(VBLINE)=" ------------- ---------- ------- ------------ --------- ------ --------- -------- --------"
SET VBLINE=VBLINE+1
+8 SET (VBA,VBB)=0
FOR
SET VBA=$ORDER(^TMP("VBA",$JOB,VBA))
if VBA=""
QUIT
SET VBB=^TMP("VBA",$JOB,VBA)
Begin DoDot:1
+9 SET VBDATE=9999999-VBA
DO VBDAT1
SET VBDTA=VBDATE
+10 SET VBC=^TMP("VBA",$JOB,VBA)
+11 SET VBDATE=$PIECE(VBC,"^",14)
IF VBDATE]""
DO VBDAT1
SET VBDST=VBDATE
+12 IF $PIECE(VBC,"^",14)=""
SET VBDST=" "
+13 SET VBABORH=$JUSTIFY($PIECE(VBC,"^",6),2)_" "_$JUSTIFY($PIECE(VBC,"^",7),3)_" "
SET VBABORH=$EXTRACT(VBABORH,1,14)
+14 SET VBUNIT=$PIECE(VBC,"^",3)
SET VBUNIT=VBUNIT_$EXTRACT(VBX,$LENGTH(VBUNIT),13)
+15 SET VBPRID=$PIECE(VBC,"^",11)
SET VBPRID=VBPRID_$EXTRACT(VBX,$LENGTH(VBPRID),9)
+16 SET VBLOC=$EXTRACT($PIECE(VBC,"^",10),1,10)
SET VBLOC=VBLOC_$EXTRACT(VBX,1,(11-$LENGTH(VBLOC)))
+17 SET VBLINE(VBLINE)=" "_VBDTA_" "_VBDST_" "_VBUNIT_" "_VBPRID_" "_$EXTRACT($PIECE(VBC,"^",13),1,57)_$EXTRACT(VBX,1,(58-$LENGTH($PIECE(VBC,"^",13))))_" "
+18 SET VBLINE(VBLINE)=VBLINE(VBLINE)_VBABORH_" "_$PIECE(VBC,"^",2)_" "_VBLOC_$PIECE(VBC,"^",9)
SET VBLINE=VBLINE+1
End DoDot:1
+19 QUIT
INSTLK ;Lookup Institution
+1 DO FIND^DIC(4,,.01,"MX",VBINST,,"D",,,"VBINST1","VBERR")
+2 SET VBINST=$GET(VBINST1("DILIST","ID",1,.01))
+3 QUIT
CPRS ;Call to CPRS^VBECA3B - DBIA 3880
+1 NEW ID,ID1,ID2,ERROR
+2 KILL ^TMP("BBD",$JOB)
+3 DO CPRS^VBECA3B
+4 WRITE !!!,"Specimen: "
+5 IF $ORDER(^TMP("BBD",$JOB,"SPECIMEN",0))
Begin DoDot:1
+6 SET ID=0
FOR
SET ID=$ORDER(^TMP("BBD",$JOB,"SPECIMEN",ID))
if 'ID
QUIT
WRITE !?2,^(ID)
Begin DoDot:2
+7 SET ID1=0
FOR
SET ID1=$ORDER(^TMP("BBD",$JOB,"SPECIMEN",ID,ID1))
if 'ID1
QUIT
if $DATA(^(ID1))#2
WRITE !,"."_^(ID1)
Begin DoDot:3
+8 SET ID2=0
FOR
SET ID2=$ORDER(^TMP("BBD",$JOB,"SPECIMEN",ID,ID1,ID2))
if 'ID2
QUIT
if $DATA(^(ID2))#2
WRITE !,".."_^(ID2)
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
COMPREQ ;Component Requests
+1 DO INCRL(3)
+2 SET VBLINE(VBLINE)="COMPONENT REQUESTS:"
SET VBLINE=VBLINE+1
+3 IF '$ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",0))
DO INCRL(1)
SET VBLINE(VBLINE)=" No Component Requests."
SET VBLINE=VBLINE+1
QUIT
+4 SET VBLINE(VBLINE)=" Component Type Qty Request date Date wanted Requestor By"
SET VBLINE=VBLINE+1
+5 SET VBLINE(VBLINE)=" -------------- --- ------------ ----------- --------- --"
SET VBLINE=VBLINE+1
+6 IF $ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",0))
Begin DoDot:1
+7 SET ID=0
FOR
SET ID=$ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",ID))
if 'ID
QUIT
SET VBA=^(ID)
Begin DoDot:2
+8 SET VBDATE=$PIECE(VBA,"^",3)
DO VBDAT1
SET VBREQD=VBDATE
SET VBDATE=$PIECE(VBA,"^",4)
DO VBDAT1
SET VBWNTD=VBDTNT
+9 SET VBREQR=$$GET1^DIQ(200,$PIECE(VBA,"^",5),1)
SET VBREQBY=$$GET1^DIQ(200,$PIECE(VBA,"^",6),1)
SET VBREQR=$EXTRACT(VBREQR_" ",1,5)
+10 SET VBLINE(VBLINE)=" "_$EXTRACT($PIECE(VBA,"^"),1,20)_$EXTRACT(VBX,$LENGTH($PIECE(VBA,"^")),20)_$PIECE(VBA,"^",2)_$EXTRACT(VBX,$LENGTH($PIECE(VBA,"^",2)),3)_VBREQD_" "_VBWNTD_" "_VBREQR_" "_VBREQBY
SET VBLINE=VBLINE+1
End DoDot:2
End DoDot:1
+11 QUIT
TRAN ;Call to TRAN^VBECA4 for Tranfused Units - DBIA 3176
+1 KILL ^TMP("TRAN",$JOB),^TMP("ZTRAN",$JOB)
+2 DO TRAN^VBECA4(+DFN,"TRAN")
+3 SET CNT=0
FOR ID="RBC","FFP","PLT","CRY","PLA","SER","GRA","WB"
SET CNT=CNT+1
SET ORAY(ID)=CNT
+4 SET ID=0
FOR
SET ID=$ORDER(^TMP("TRAN",$JOB,ID))
if 'ID
QUIT
SET GMR=^(ID)
SET COMP=$PIECE(GMR,"^",2)
SET COMP=$PIECE(COMP,"\",2)
SET COMP=$EXTRACT($PIECE(COMP,";"),1,3)
SET COMPSEQ=$SELECT($DATA(ORAY(COMP)):ORAY(COMP),1:99)
Begin DoDot:1
+5 IF '$DATA(^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ))
SET ^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ)=GMR_"^"_1
QUIT
+6 SET CNT=$PIECE(^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ),"^",3)
SET $PIECE(^(COMPSEQ),"^",3)=CNT+1
End DoDot:1
+7 DO INCRL(3)
SET VBLINE(VBLINE)="TRANSFUSED UNITS"
SET VBLINE=VBLINE+1
SET $PIECE(VBX," ",256)=""
+8 IF '$ORDER(^TMP("TRAN",$JOB,0))
DO INCRL(1)
SET VBLINE(VBLINE)=" No Transfused Units."
SET VBLINE=VBLINE+1
QUIT
+9 SET VBLINE(VBLINE)=" Date Transfused Unit ID Product Code Product Name ABO/Rh"
SET VBLINE=VBLINE+1
+10 SET VBLINE(VBLINE)=" --------------- ------- ------------ ------------ ------"
SET VBLINE=VBLINE+1
+11 SET ID=0
FOR
SET ID=$ORDER(^TMP("TRAN",$JOB,ID))
if 'ID
QUIT
SET VBA=^(ID)
SET VBDATE=$PIECE(VBA,"^")
DO VBDAT1
Begin DoDot:1
+12 SET VBTR=$PIECE(VBA,"^",2)
+13 SET VBQ=$PIECE(VBTR,"\")
SET VBQ=$JUSTIFY("("_VBQ_")",5)
+14 SET VBT=$PIECE(VBA,"^",7)
SET VBT=VBT_$EXTRACT(VBX,$LENGTH(VBT),57)
+15 SET VBABORH=$PIECE(VBA,"^",3)_" "_$PIECE(VBA,"^",4)_" "
SET VBABORH=$EXTRACT(VBABORH,1,14)
+16 SET VBUNIT=$PIECE(VBA,"^",6)
SET VBUNIT=VBUNIT_$EXTRACT(VBX,$LENGTH(VBUNIT),14)
+17 SET VBPROD=$PIECE(VBA,"^",5)
SET VBPROD=VBPROD_$EXTRACT(VBX,$LENGTH(VBPROD),15)
+18 SET VBLINE(VBLINE)=" "_VBDTNT_" "_VBUNIT_VBPROD_VBT_VBABORH
SET VBLINE=VBLINE+1
+19 ;S VBLINE(VBLINE)=" "_VBDTNT_" ("_VBQ_")"_$E(" ",$L(VBQ),4)_$P(VBT,";"),VBLINE=VBLINE+1
End DoDot:1
+20 ;S VBTXT=1,VBA="A" F S VBA=$O(^TMP("TRAN",$J,VBA)) Q:VBA="" S VBLINE(VBLINE)=$S(VBTXT:" Blood Product Key: ",1:" ")_VBA_" = "_^(VBA),VBLINE=VBLINE+1,VBTXT=0
+21 QUIT
TRRX ;Call to TRRX^VBECA1 for Transfusion Reactions - DBIA 3181, 3187
+1 DO TRRX^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
+2 DO INCRL(3)
SET VBLINE(VBLINE)="TRANSFUSION REACTIONS: "
SET VBLINE=VBLINE+1
SET $PIECE(VBX," ",256)=""
+3 IF '$ORDER(ORARR("TRRX",0))
DO INCRL(1)
SET VBLINE(VBLINE)=" No Transfusion Reactions."
SET VBLINE=VBLINE+1
QUIT
+4 IF $ORDER(ORARR("TRRX",0))
Begin DoDot:1
+5 ;W !?2,ORARR("TRRX",ID)
SET ID=0
FOR
SET ID=$ORDER(ORARR("TRRX",ID))
if 'ID
QUIT
Begin DoDot:2
+6 SET VBRXTYP=$PIECE(ORARR("TRRX",ID),"^",2)
+7 SET Y=$PIECE(ORARR("TRRX",ID),"^")
DO DD^%DT
if Y=""
QUIT
IF VBRXTYP=""
SET VBRXTYP="Unknown"
+8 SET VBTRRX(VBRXTYP,ID)=Y_"^"_$SELECT($PIECE(ORARR("TRRX",ID),"^",3)]"":$PIECE(ORARR("TRRX",ID),"^",3),1:"None")_"^"_$SELECT($PIECE(ORARR("TRRX",ID),"^",4)]"":$PIECE(ORARR("TRRX",ID),"^",4),1:" None")
+9 SET ID1=""
FOR
SET ID1=$ORDER(ORARR("TRRX",ID,ID1))
if 'ID1
QUIT
SET VBTRRX(VBRXTYP,ID,ID1)=ORARR("TRRX",ID,ID1)
End DoDot:2
End DoDot:1
+10 SET (ID,ID1)=""
FOR
SET ID=$ORDER(VBTRRX(ID))
if ID=""
QUIT
SET VBLINE(VBLINE)=" Type: "_ID
SET VBLINE=VBLINE+1
DO TRRXHDR
Begin DoDot:1
+11 FOR
SET ID1=$ORDER(VBTRRX(ID,ID1))
if 'ID1
QUIT
SET VBLINE(VBLINE)=" "_$PIECE(VBTRRX(ID,ID1),"^")_$EXTRACT(VBX,$LENGTH($PIECE(VBTRRX(ID,ID1),"^")),26)_$PIECE(VBTRRX(ID,ID1),"^",2)_$EXTRACT(VBX,$LENGTH($PIECE(VBTRRX(ID,ID1),"^")),27)_$PIECE(VBTRRX(ID,ID1),"^",3)
SET VBLINE=VBLINE+1
Begin DoDot:2
+12 if $ORDER(VBTRRX(ID,ID1,""))
SET VBLINE(VBLINE)=" Comment: "
SET VBLINE=VBLINE+1
+13 ;W !?5,VBTRRX(ID,ID1,ID2)
SET ID2=""
FOR
SET ID2=$ORDER(VBTRRX(ID,ID1,ID2))
if 'ID2
QUIT
SET VBLINE(VBLINE)=" "_VBTRRX(ID,ID1,ID2)
SET VBLINE=VBLINE+1
End DoDot:2
End DoDot:1
+14 QUIT
TRRXHDR ;Transfusion Reaction Header
+1 SET VBLINE(VBLINE)=" Date/Time Unit Id Component"
SET VBLINE=VBLINE+1
SET VBLINE(VBLINE)=" --------- ------- ---------"
SET VBLINE=VBLINE+1
+2 QUIT
PARSE ;Parse Record
+1 NEW GMI,X
+2 SET TD=$$FMTE^XLFDT(+GMR)
+3 SET GMA(1)=$PIECE(GMR,U,2)
SET BPN=$LENGTH(GMA(1),";")
+4 IF $PIECE(GMA(1),";",BPN)=""
SET BPN=BPN-1
+5 FOR GMI=2:1:BPN
SET GMA(GMI)="("_$PIECE($PIECE(GMA(1),";",GMI),"\")_") "_$PIECE($PIECE(GMA(1),";",GMI),"\",2)
+6 SET GMA(1)="("_$PIECE($PIECE(GMA(1),";",1),"\")_") "_$PIECE($PIECE(GMA(1),";",1),"\",2)
+7 QUIT
WRT ; Writes the Transfusion Record for each day
+1 NEW GML,GMI1,GMI2,GMM,GMJ
+2 SET GMM=$SELECT(BPN#4:1,1:0)
SET GML=BPN\4+GMM
+3 WRITE TD
+4 FOR GMI1=1:1:GML
Begin DoDot:1
+5 FOR GMI2=1:1:($SELECT((GMI1=GML)&(BPN#4):BPN#4,1:4))
Begin DoDot:2
+6 SET GMJ=((GMI1-1)*4)+GMI2
+7 WRITE ?(((GMI2-1)*15)+13),GMA(GMJ)
+8 IF $SELECT(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0)
WRITE !
End DoDot:2
End DoDot:1
+9 QUIT
INCRL(I) ;Increment line
+1 FOR I=1:1:I
SET VBLINE(VBLINE)=""
SET VBLINE=VBLINE+1
+2 QUIT
