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

VBECRPT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Note: This routine supports data exchange with an FDA registered
  1. ; medical device. As such, it may not be changed in any way without
  1. ; prior written approval from the medical device manufacturer.
  1. ;
  1. ; Integration Agreements:
  1. ; Reference to GETS^DIQ is supported by ICR #2056
  1. ; Reference to $$GET1^DIQ supported by ICR #2052
  1. ; Reference to DD^%DT supported by ICR #10003
  1. ; Reference to FIND^DIC supported by ICR #2051
  1. ; Reference to GETWP^XPAR supported by ICR #2263
  1. ;
  1. EN ;Add sections as they are finished.
  1. S VBLINE=1,PATID="`"_DFN,PATNAM=$P(^DPT(DFN,0),"^"),PATDOB=$P(^DPT(DFN,0),"^",3) D HEADER,ABORH
  1. I $E(ABORH,1,2)="1^" D INCRL(3) D G EXIT
  1. . 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
  1. D ABID,TRRX,AVUNIT,DFN,COMPREQ,TRAN ;COMPREQ must follow DFN
  1. EXIT ;Set up to print and clean up.
  1. K ^TMP("ORLRC",$J) D INCRL(4)
  1. S VBA=0 F S VBA=$O(VBLINE(VBA)) Q:VBA="" S ^TMP("ORLRC",$J,VBA,0)=VBLINE(VBA)
  1. 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
  1. Q
  1. S VBLINE(VBLINE)=" ---- BLOOD BANK ----",VBLINE=VBLINE+1
  1. Q
  1. TEST ;Calls
  1. N ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR,ERROR
  1. D ABORH,ABID,TRRX,DFN,CPRS,TRAN
  1. W !!!,"CROSSMATCHED UNITS: "
  1. I $O(^TMP("VBDATA",$J,"CROSSMATCH",0)) D
  1. . S ID=0 F S ID=$O(^TMP("VBDATA",$J,"CROSSMATCH",ID)) Q:'ID W !?2,^(ID)
  1. K ^TMP("VBDATA",$J),^TMP("TRRX",$J),^TMP("TRAN",$J)
  1. Q
  1. OEAPI ;Call to OEAPI^VBECA3
  1. N DIV,ORSTN,ERROR,ORVB
  1. S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3)
  1. D OEAPI^VBECA3(.ORVB,+ORVP,ORSTN)
  1. I $O(ORVB(0)) D
  1. . W !!!,"Array returned from OEAPI^VBECA3 API in ORVB():",!
  1. K ^TMP("OR",$J),^TMP("VBECRPC",$J),^TMP("VBECS_XML_RES",$J),^TMP("VBEC_OE_DATA",$J)
  1. Q
  1. ABORH ;Call to ABORH^VBECA1 for ABO/Rh - DBIA 3181
  1. S ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB) Q:ABORH["1^"
  1. D INCRL(3) ;F I=1:1:3 S VBLINE(VBLINE)="",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)="ABO/RH: " I ABORH=""!(ABORH=" ") S VBLINE(VBLINE)=" No ABO/Rh results.",VBLINE=VBLINE+1 Q
  1. S:ABO="I " ABO="Inconclusive "
  1. S VBLINE(VBLINE)=VBLINE(VBLINE)_$G(ABO)_" "_$S(RH="P":"Positive",RH="N":"Negative",RH="I":"Inconclusive",1:""),VBLINE=VBLINE+1
  1. Q
  1. ABID ;Call to ABID^VBECA1 for Antibodies Identified - DBIA 3181, 3184
  1. D ABID^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
  1. D INCRL(3)
  1. S VBLINE(VBLINE)="ANTIBODIES IDENTIFIED: ",VBLINE=VBLINE+1
  1. I '$O(ORARR("ABID","")) D INCRL(1) S VBLINE(VBLINE)=" No Antibody results.",VBLINE=VBLINE+1 G TREQ
  1. S ID=0,VBABID=" " F S ID=$O(ORARR("ABID",ID)) Q:'ID S VBABID=VBABID_$S(VBABID=" ":"",1:", ")_ORARR("ABID",ID) D
  1. . S ID1=0 F S ID1=$O(ORARR("ABID",ID,ID1)) Q:'ID1 S VBABIDC(ID1)=ORARR("ABID",ID,ID1)
  1. S VBLINE(VBLINE)=" "_VBABID,VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" COMMENT:",VBLINE=VBLINE+1
  1. ;S ID1=0 F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=" "_VBABIDC(ID1),VBLINE=VBLINE+1
  1. S ID1=0 S VBLINE(VBLINE)=" " F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
  1. S VBLINE=VBLINE+1
  1. K VBABID,VBABIDC
  1. TREQ ;W !!,"Transfusion Requirements"
  1. D INCRL(2) S VBLINE(VBLINE)="TRANSFUSION REQUIREMENTS",VBLINE=VBLINE+1
  1. I '$O(ORARR("ABID","TR","")) D INCRL(1) S VBLINE(VBLINE)=" No Transfusion Requirements.",VBLINE=VBLINE+1 Q
  1. 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
  1. . S ID1=0 F S ID1=$O(ORARR("ABID","TR",ID,ID1)) Q:'ID1 S VBABIDC(ID1)=ORARR("ABID","TR",ID,ID1)
  1. S VBLINE(VBLINE)=" "_VBABID,VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" COMMENT:",VBLINE=VBLINE+1
  1. S ID1=0 S VBLINE(VBLINE)=" " F S ID1=$O(VBABIDC(ID1)) Q:ID1="" S VBLINE(VBLINE)=VBLINE(VBLINE)_" "_VBABIDC(ID1)
  1. S VBLINE=VBLINE+1
  1. Q
  1. DFN ;Call to DFN^VBECA3A - DBIA 3879
  1. K ^TMP("VBDATA",$J)
  1. D DFN^VBECA1B(DFN)
  1. D INCRL(2) K ^TMP("VBRPTDTA",$J) S VBSPCCML=1,$P(VBX," ",256)=""
  1. S VBLINE(VBLINE)="DIAGNOSTIC TESTS",VBLINE=VBLINE+1
  1. I '$O(^TMP("VBDATA",$J,"SPECIMEN","")) D INCRL(1) S VBLINE(VBLINE)=" No results.",VBLINE=VBLINE+1 Q
  1. S (ID,ID1,ID2)="" F S ID=$O(^TMP("VBDATA",$J,"SPECIMEN",ID)) Q:'ID D
  1. . S VBSPCID=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",9)
  1. . S VBDATE=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",8) D VBDAT S VBSPDT=VBDATE,VBDPDTI=VBDATI
  1. . S VBDPDTI=VBDATI_" "_VBSPCID
  1. . S VBSPCID=VBSPCID_$E(VBX,$L(VBX),12)
  1. . S VBDATE=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",10) D VBDAT1 S VBCLDT=VBDATE,VBCLDTI=VBDATI
  1. . S VBINST=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",2) D INSTLK
  1. . S VBTN=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",5)
  1. . 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)
  1. . S:'$D(^TMP("VBRPTDTA",$J,VBDPDTI)) ^TMP("VBRPTDTA",$J,VBDPDTI)=VBSPDT_"^^^^^^^^^^"_VBINST_"^"_VBCLDT_"^"_VBSPCID
  1. . S VBRSLT=$P(^TMP("VBDATA",$J,"SPECIMEN",ID),"^",7) I VBRSLT="No Agglutination" S VBRSLT=0
  1. . I VBPLC S $P(^TMP("VBRPTDTA",$J,VBDPDTI),"^",VBPLC)=VBRSLT D
  1. . . 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)
  1. . . F VBLN=4:1:6 S VBSPCCM=$G(^TMP("VBDATA",$J,"SPECIMEN",ID,VBLN)) I VBSPCCM]"" D
  1. . . . 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
  1. . . . I $D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S VBSPCCLM=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,"")) S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCLM)=""
  1. . . I $G(^TMP("VBDATA",$J,"SPECIMEN",ID,7))]"" D
  1. . . . S VBSPCCM=^TMP("VBDATA",$J,"SPECIMEN",ID,7)
  1. . . . 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
  1. . . . I $D(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM)) S VBSPCCLM=$O(^TMP("VBRPTDTA",$J,"VBSPCCM",VBSPCCM,"")) S ^TMP("VBRPTDTA",$J,VBDPDTI,"VBSPCL",VBSPCCLM)=""
  1. S VBLINE(VBLINE)="",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" |------- DAT -------|",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" |Poly| |IgG| |Comp|",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" Collection Date UID Test Date/Time ABO Rh ABS Intrp Intrp Intrp Division",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" --------------- --- -------------- ------ --- ----- ----- ----- --------",VBLINE=VBLINE+1
  1. S VBDATI="" F S VBDATI=$O(^TMP("VBRPTDTA",$J,VBDATI)) Q:'VBDATI S VBDATA=^TMP("VBRPTDTA",$J,VBDATI) D ;
  1. . D INCRL(1) S VBLINE(VBLINE)=""
  1. . I $O(^TMP("VBRPTDTA",$J,VBDATI,"VBSPCL",0)) S VBSPCL=0 S VBLINE(VBLINE)="(" D
  1. . . 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:")")
  1. . S VBLINE(VBLINE)=VBLINE(VBLINE)_$E(" ",1,(7-$L(VBLINE(VBLINE))))
  1. . 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
  1. . . 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))))
  1. . . S VBLINE(VBLINE)=VBLINE(VBLINE)_$P(VBDATA,"^",10)_$E(VBX,1,(7-$L($P(VBDATA,"^",10))))_$P(VBDATA,"^",11),VBLINE=VBLINE+1
  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
  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
  1. I $O(VBCMO(0))="" Q
  1. D INCRL(2) S VBLINE(VBLINE)=" ----- STANDARD COMMENTS FOR DIAGNOSTIC TESTS ABOVE -----",VBLINE=VBLINE+1
  1. S VBI="" F S VBI=$O(VBCMO(VBI)) Q:VBI="" S VBLINE(VBLINE)="("_VBI_") "_VBCMO(VBI),VBLINE=VBLINE+1
  1. Q
  1. VBDAT ;CONVERT DATE 3200114.16132
  1. S VBDATI=9999999-VBDATE
  1. VBDAT1 S Y=VBDATE D DD^%DT S VBT=$P($P(Y,"@",2),":",1,2)
  1. S VBY=(($E(VBDATE,1)*100)+1700)+$E(VBDATE,2,3),VBM=$E(VBDATE,4,5),VBD=$E(VBDATE,6,7)
  1. S VBDATE=VBM_"/"_VBD_"/"_VBY_"@"_VBT
  1. S VBDTNT=VBM_"/"_VBD_"/"_VBY
  1. Q
  1. AVUNIT ;Available Units
  1. D AVUNIT^VBECA4(DFN,"VBA"),INCRL(3)
  1. S VBLINE(VBLINE)="AVAILABLE/ISSUED UNITS:",VBLINE=VBLINE+1
  1. I $O(^TMP("VBA",$J,""))="" D INCRL(1) S VBLINE(VBLINE)=" No Available/Issued Units.",VBLINE=VBLINE+1 Q
  1. S VBA=$G(^TMP("VBA",$J,0)),$P(VBX," ",256)=""
  1. Q:VBA=""
  1. S VBLINE(VBLINE)=" Date Assigned Issue Date Unit ID Product Code Product Name ABO/Rh Exp. Date Location Division",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" ------------- ---------- ------- ------------ --------- ------ --------- -------- --------",VBLINE=VBLINE+1
  1. S (VBA,VBB)=0 F S VBA=$O(^TMP("VBA",$J,VBA)) Q:VBA="" S VBB=^TMP("VBA",$J,VBA) D
  1. . S VBDATE=9999999-VBA D VBDAT1 S VBDTA=VBDATE
  1. . S VBC=^TMP("VBA",$J,VBA)
  1. . S VBDATE=$P(VBC,"^",14) I VBDATE]"" D VBDAT1 S VBDST=VBDATE
  1. . I $P(VBC,"^",14)="" S VBDST=" "
  1. . S VBABORH=$J($P(VBC,"^",6),2)_" "_$J($P(VBC,"^",7),3)_" ",VBABORH=$E(VBABORH,1,14)
  1. . S VBUNIT=$P(VBC,"^",3),VBUNIT=VBUNIT_$E(VBX,$L(VBUNIT),13)
  1. . S VBPRID=$P(VBC,"^",11),VBPRID=VBPRID_$E(VBX,$L(VBPRID),9)
  1. . S VBLOC=$E($P(VBC,"^",10),1,10),VBLOC=VBLOC_$E(VBX,1,(11-$L(VBLOC)))
  1. . S VBLINE(VBLINE)=" "_VBDTA_" "_VBDST_" "_VBUNIT_" "_VBPRID_" "_$E($P(VBC,"^",13),1,57)_$E(VBX,1,(58-$L($P(VBC,"^",13))))_" "
  1. . S VBLINE(VBLINE)=VBLINE(VBLINE)_VBABORH_" "_$P(VBC,"^",2)_" "_VBLOC_$P(VBC,"^",9),VBLINE=VBLINE+1
  1. Q
  1. INSTLK ;Lookup Institution
  1. D FIND^DIC(4,,.01,"MX",VBINST,,"D",,,"VBINST1","VBERR")
  1. S VBINST=$G(VBINST1("DILIST","ID",1,.01))
  1. Q
  1. CPRS ;Call to CPRS^VBECA3B - DBIA 3880
  1. N ID,ID1,ID2,ERROR
  1. K ^TMP("BBD",$J)
  1. D CPRS^VBECA3B
  1. W !!!,"Specimen: "
  1. I $O(^TMP("BBD",$J,"SPECIMEN",0)) D
  1. . S ID=0 F S ID=$O(^TMP("BBD",$J,"SPECIMEN",ID)) Q:'ID W !?2,^(ID) D
  1. .. S ID1=0 F S ID1=$O(^TMP("BBD",$J,"SPECIMEN",ID,ID1)) Q:'ID1 W:$D(^(ID1))#2 !,"."_^(ID1) D
  1. ... S ID2=0 F S ID2=$O(^TMP("BBD",$J,"SPECIMEN",ID,ID1,ID2)) Q:'ID2 W:$D(^(ID2))#2 !,".."_^(ID2)
  1. Q
  1. COMPREQ ;Component Requests
  1. D INCRL(3)
  1. S VBLINE(VBLINE)="COMPONENT REQUESTS:",VBLINE=VBLINE+1
  1. I '$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",0)) D INCRL(1) S VBLINE(VBLINE)=" No Component Requests.",VBLINE=VBLINE+1 Q
  1. S VBLINE(VBLINE)=" Component Type Qty Request date Date wanted Requestor By",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" -------------- --- ------------ ----------- --------- --",VBLINE=VBLINE+1
  1. I $O(^TMP("VBDATA",$J,"COMPONENT REQUEST",0)) D
  1. . S ID=0 F S ID=$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",ID)) Q:'ID S VBA=^(ID) D
  1. . . S VBDATE=$P(VBA,"^",3) D VBDAT1 S VBREQD=VBDATE S VBDATE=$P(VBA,"^",4) D VBDAT1 S VBWNTD=VBDTNT
  1. . . S VBREQR=$$GET1^DIQ(200,$P(VBA,"^",5),1),VBREQBY=$$GET1^DIQ(200,$P(VBA,"^",6),1),VBREQR=$E(VBREQR_" ",1,5)
  1. . . 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
  1. Q
  1. TRAN ;Call to TRAN^VBECA4 for Tranfused Units - DBIA 3176
  1. K ^TMP("TRAN",$J),^TMP("ZTRAN",$J)
  1. D TRAN^VBECA4(+DFN,"TRAN")
  1. S CNT=0 F ID="RBC","FFP","PLT","CRY","PLA","SER","GRA","WB" S CNT=CNT+1,ORAY(ID)=CNT
  1. 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
  1. . I '$D(^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ)) S ^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ)=GMR_"^"_1 Q
  1. . S CNT=$P(^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ),"^",3),$P(^(COMPSEQ),"^",3)=CNT+1
  1. D INCRL(3) S VBLINE(VBLINE)="TRANSFUSED UNITS",VBLINE=VBLINE+1,$P(VBX," ",256)=""
  1. I '$O(^TMP("TRAN",$J,0)) D INCRL(1) S VBLINE(VBLINE)=" No Transfused Units.",VBLINE=VBLINE+1 Q
  1. S VBLINE(VBLINE)=" Date Transfused Unit ID Product Code Product Name ABO/Rh",VBLINE=VBLINE+1
  1. S VBLINE(VBLINE)=" --------------- ------- ------------ ------------ ------",VBLINE=VBLINE+1
  1. S ID=0 F S ID=$O(^TMP("TRAN",$J,ID)) Q:'ID S VBA=^(ID),VBDATE=$P(VBA,"^") D VBDAT1 D
  1. . S VBTR=$P(VBA,"^",2)
  1. . S VBQ=$P(VBTR,"\"),VBQ=$J("("_VBQ_")",5)
  1. . S VBT=$P(VBA,"^",7),VBT=VBT_$E(VBX,$L(VBT),57)
  1. . S VBABORH=$P(VBA,"^",3)_" "_$P(VBA,"^",4)_" ",VBABORH=$E(VBABORH,1,14)
  1. . S VBUNIT=$P(VBA,"^",6),VBUNIT=VBUNIT_$E(VBX,$L(VBUNIT),14)
  1. . S VBPROD=$P(VBA,"^",5),VBPROD=VBPROD_$E(VBX,$L(VBPROD),15)
  1. . S VBLINE(VBLINE)=" "_VBDTNT_" "_VBUNIT_VBPROD_VBT_VBABORH,VBLINE=VBLINE+1
  1. . ;S VBLINE(VBLINE)=" "_VBDTNT_" ("_VBQ_")"_$E(" ",$L(VBQ),4)_$P(VBT,";"),VBLINE=VBLINE+1
  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
  1. Q
  1. TRRX ;Call to TRRX^VBECA1 for Transfusion Reactions - DBIA 3181, 3187
  1. D TRRX^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
  1. D INCRL(3) S VBLINE(VBLINE)="TRANSFUSION REACTIONS: ",VBLINE=VBLINE+1 S $P(VBX," ",256)=""
  1. I '$O(ORARR("TRRX",0)) D INCRL(1) S VBLINE(VBLINE)=" No Transfusion Reactions.",VBLINE=VBLINE+1 Q
  1. I $O(ORARR("TRRX",0)) D
  1. . S ID=0 F S ID=$O(ORARR("TRRX",ID)) Q:'ID D ;W !?2,ORARR("TRRX",ID)
  1. . . S VBRXTYP=$P(ORARR("TRRX",ID),"^",2)
  1. . . S Y=$P(ORARR("TRRX",ID),"^") D DD^%DT Q:Y="" I VBRXTYP="" S VBRXTYP="Unknown"
  1. . . 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")
  1. . . S ID1="" F S ID1=$O(ORARR("TRRX",ID,ID1)) Q:'ID1 S VBTRRX(VBRXTYP,ID,ID1)=ORARR("TRRX",ID,ID1)
  1. S (ID,ID1)="" F S ID=$O(VBTRRX(ID)) Q:ID="" S VBLINE(VBLINE)=" Type: "_ID,VBLINE=VBLINE+1 D TRRXHDR D
  1. . 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
  1. . . S:$O(VBTRRX(ID,ID1,"")) VBLINE(VBLINE)=" Comment: ",VBLINE=VBLINE+1
  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)
  1. Q
  1. TRRXHDR ;Transfusion Reaction Header
  1. S VBLINE(VBLINE)=" Date/Time Unit Id Component",VBLINE=VBLINE+1,VBLINE(VBLINE)=" --------- ------- ---------",VBLINE=VBLINE+1
  1. Q
  1. PARSE ;Parse Record
  1. N GMI,X
  1. S TD=$$FMTE^XLFDT(+GMR)
  1. S GMA(1)=$P(GMR,U,2),BPN=$L(GMA(1),";")
  1. I $P(GMA(1),";",BPN)="" S BPN=BPN-1
  1. F GMI=2:1:BPN S GMA(GMI)="("_$P($P(GMA(1),";",GMI),"\")_") "_$P($P(GMA(1),";",GMI),"\",2)
  1. S GMA(1)="("_$P($P(GMA(1),";",1),"\")_") "_$P($P(GMA(1),";",1),"\",2)
  1. Q
  1. WRT ; Writes the Transfusion Record for each day
  1. N GML,GMI1,GMI2,GMM,GMJ
  1. S GMM=$S(BPN#4:1,1:0),GML=BPN\4+GMM
  1. W TD
  1. F GMI1=1:1:GML D
  1. . F GMI2=1:1:($S((GMI1=GML)&(BPN#4):BPN#4,1:4)) D
  1. .. S GMJ=((GMI1-1)*4)+GMI2
  1. .. W ?(((GMI2-1)*15)+13),GMA(GMJ)
  1. .. I $S(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0) W !
  1. Q
  1. INCRL(I) ;Increment line
  1. F I=1:1:I S VBLINE(VBLINE)="",VBLINE=VBLINE+1
  1. Q