- 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 Jan 18, 2025@03:45:43 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