- ORWLR1 ; SLC/DCM - VBEC Blood Bank Report ;Dec 02, 2021@12:51:03
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**172,212,309,332,375,527,405**;Dec 17, 1997;Build 211
- ;Re-write of ^LR7OSBR
- ;DBIA 7203 ^VBECRPT
- EN(DFN) ;Get Blood Bank Report
- Q:'$G(DFN)
- D ^VBECRPT ;RLM
- Q
- N GCNT,CCNT,GIOSL,GIOM,ORABORH,PATID,PATNAM,PATDOB,ORN
- S PATID="`"_DFN,PATNAM=$P(^DPT(DFN,0),"^"),PATDOB=$P(^(0),"^",3) ;Why PATNAM and PATDOB???
- K ^TMP("ORLRC",$J)
- S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80
- S ORABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB) ;Get ABO/RH
- I $E(ORABORH,1,2)="1^" S ORX("ERROR")=ORABORH D Q ;Isolate error condition
- . N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND
- . S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80
- . ;S OROOT=$NA(^TMP("ORVBEC",$J)) ;p375 line removed because it is not needed and causing issues
- . D ERROR^ORWDXVB2("^TMP(""ORLRC"",$J)")
- S ORN(2.91)="DIRECT AHG TEST COMMENT",ORN(8)="ANTIBODY SCREEN COMMENT"
- S ORN(10.3)="ABO TESTING COMMENT",ORN(11.3)="RH TESTING COMMENT"
- D EN^ORWLR2
- Q
- REPORT ;Blood Bank Report for M reports menu
- Q:'$G(DFN)
- N DIC,ID,ORDFN,ORY,PAGE,XQORNOD,ORDAYSBK
- S ORDFN=DFN,ID=2
- D BLR^ORWRP1(.ORY,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDAYSBK,.REMOTE)
- Q:'$L(ORY)
- S PAGE=1
- ;D HEAD^ORWRPP1(ORDFN,PAGE,"PATIENT BLOOD BANK REPORT",$G(STATION))
- ;D HURL^ORWRPP1(.ORY,ORDFN,"PATIENT BLOOD BANK REPORT",,,1)
- ;modified lab header to include facility address
- D LRHEAD^ORWRPP1(ORDFN,PAGE,"PATIENT BLOOD BANK REPORT",$G(STATION))
- D LRHURL^ORWRPP1(.ORY,ORDFN,"PATIENT BLOOD BANK REPORT",,,1)
- Q
- GETPAT(ERR) ;Setup Patient Variables
- N ORPNM
- S ERR=0
- D EN2^ORUDPA
- I 'ORVP S ERR=1 Q
- S PATID="`"_+ORVP,PATNAM=ORPNM,PATDOB=$P(^DPT(+ORVP,0),"^",3)
- D PAT^VBECA1A
- W !,LRDFN
- I $O(VBECERR(0)) D S ERR=1 Q
- . S ERR=0 F S ERR=$O(VBECERR(ERR)) Q:'ERR W !?5," ERR:"_VBECERR(1)
- Q
- TEST ;Test calls
- N ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR,ERROR
- D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D ABORH,ABID,TRRX,DFN,CPRS,TRAN
- I $O(^TMP("VBDATA",$J,"CROSSMATCH",0)) D
- . W !,"Crossmatched Units: " 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 ;Test call to OEAPI^VBECA3
- N DIV,ORSTN,ERROR,ORVB
- D GETPAT^ORWLR1(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- 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():",!
- . ;ZW ORVB
- K ^TMP("OR",$J),^TMP("VBECRPC",$J),^TMP("VBECS_XML_RES",$J),^TMP("VBEC_OE_DATA",$J)
- Q
- ABORH ;Test call to ABORH^VBECA1 for ABO/Rh - DBIA 3181
- N ERROR
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- S ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB) W !,"ABO/RH: "_ABORH
- Q
- ABID ;Test call to ABID^VBECA1 for Antibodies Identified - DBIA 3181, 3184
- N ID,ERROR,ORPARNT
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D ABID^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR) I $O(ARR("ABID",0)) D
- . W !,"Antibodies Identified: " S ID=0 F S ID=$O(ARR("ABID",ID)) Q:'ID W !?2,ARR("ABID",ID)
- Q
- DFN ;Test call to DFN^VBECA3A - DBIA 3879
- N ID,ID1,ID2,ERROR
- K ^TMP("VBDATA",$J)
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D DFN^VBECA3A(DFN)
- I $O(^TMP("VBDATA",$J,"COMPONENT REQUEST",0)) D
- . W !,"Component request: " S ID=0 F S ID=$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",ID)) Q:'ID W !?2,^(ID) D
- .. S ID1=0 F S ID1=$O(^TMP("VBDATA",$J,"COMPONENT REQUEST",ID,ID1)) Q:'ID1 W !,"."_^(ID1)
- I $O(^TMP("VBDATA",$J,"SPECIMEN",0)) D
- . W !,"Specimen: " S ID=0 F S ID=$O(^TMP("VBDATA",$J,"SPECIMEN",ID)) Q:'ID W !?2,^(ID) D
- .. S ID1=0 F S ID1=$O(^TMP("VBDATA",$J,"SPECIMEN",ID,ID1)) Q:'ID1 W:$D(^(ID1))#2 !,"."_^(ID1) D
- ... S ID2=0 F S ID2=$O(^TMP("VBDATA",$J,"SPECIMEN",ID,ID1,ID2)) Q:'ID2 W:$D(^(ID2))#2 !,".."_^(ID2)
- I $O(^TMP("VBDATA",$J,"UNIT",0)) D
- . W !,"Available Units: "
- . S ID=0 F S ID=$O(^TMP("VBDATA",$J,"UNIT",ID)) Q:'ID W !?2,^(ID)
- Q
- CPRS ;Test call to CPRS^VBECA3B - DBIA 3880
- N ID,ID1,ID2,ERROR
- K ^TMP("BBD",$J)
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D CPRS^VBECA3B
- I $O(^TMP("BBD",$J,"SPECIMEN",0)) D
- . W !,"Specimen: " 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
- TRAN ;Test call to TRAN^VBECA4 for Tranfused Units - DBIA 3176
- N BPN,ID,GMI,GMR,ERROR,CNT,ORAY,COMP,COMPSEQ,X,TD
- K ^TMP("TRAN",$J),^TMP("ZTRAN",$J)
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D TRAN^VBECA4(+ORVP,"TRAN")
- ;^TMP("TRAN",$J,InverseDate)="Date^Number of Units\Product Type"
- ;^TMP("TRAN",$J,"Product Type")="Product Type Print Name"
- 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
- I $O(^TMP("ZTRAN",$J,0)) D
- . W !,"Sorted/grouped Transfused Units: ",! S ID=0
- . F S ID=$O(^TMP("ZTRAN",$J,ID)) Q:'ID S COMP="" F S COMP=$O(^TMP("ZTRAN",$J,ID,COMP)) Q:COMP="" S GMR=^(COMP) D
- .. I $P(GMR,"^",3) S $P(GMR,"^",2)=$P(GMR,"^",3)_"\"_$P($P(GMR,"^",2),"\",2)
- .. D PARSE,WRT
- I $O(^TMP("TRAN",$J,0)) D
- . W !,"Transfused Units (from VBECS API): ",! S ID=0
- . F S ID=$O(^TMP("TRAN",$J,ID)) Q:'ID S GMR=^(ID) D
- .. D PARSE,WRT
- . I $O(^TMP("TRAN",$J,"A"))'="" D
- .. W !," Blood Product Key: "
- . S GMI="A" F S GMI=$O(^TMP("TRAN",$J,GMI)) Q:GMI="" D
- .. W ?22,GMI," = ",$G(^TMP("TRAN",$J,GMI)),!
- Q
- TRRX ;Test call to TRRX^VBECA1 for Transfusion Reactions - DBIA 3181, 3187
- N ARR,ID,ERROR,ORPARNT
- I '$G(ORVP) D GETPAT(.ERROR)
- I $G(ERROR) W !,"Error on Patient lookup" Q
- D TRRX^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR) I $O(ARR("TRRX",0)) D
- . W !,"Transfusion reactions: " S ID=0 F S ID=$O(ARR("TRRX",ID)) Q:'ID W !?2,ARR("TRRX",ID)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWLR1 7145 printed Jan 18, 2025@03:37:44 Page 2
- ORWLR1 ; SLC/DCM - VBEC Blood Bank Report ;Dec 02, 2021@12:51:03
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**172,212,309,332,375,527,405**;Dec 17, 1997;Build 211
- +2 ;Re-write of ^LR7OSBR
- +3 ;DBIA 7203 ^VBECRPT
- EN(DFN) ;Get Blood Bank Report
- +1 if '$GET(DFN)
- QUIT
- +2 ;RLM
- DO ^VBECRPT
- +3 QUIT
- +4 NEW GCNT,CCNT,GIOSL,GIOM,ORABORH,PATID,PATNAM,PATDOB,ORN
- +5 ;Why PATNAM and PATDOB???
- SET PATID="`"_DFN
- SET PATNAM=$PIECE(^DPT(DFN,0),"^")
- SET PATDOB=$PIECE(^(0),"^",3)
- +6 KILL ^TMP("ORLRC",$JOB)
- +7 SET GCNT=0
- SET CCNT=1
- SET GIOSL=999999
- SET GIOM=80
- +8 ;Get ABO/RH
- SET ORABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB)
- +9 ;Isolate error condition
- IF $EXTRACT(ORABORH,1,2)="1^"
- SET ORX("ERROR")=ORABORH
- Begin DoDot:1
- +10 NEW GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND
- +11 SET (GCNT,NOPAT,NOABO)=0
- SET CCNT=1
- SET GIOSL=999999
- SET GIOM=80
- +12 ;S OROOT=$NA(^TMP("ORVBEC",$J)) ;p375 line removed because it is not needed and causing issues
- +13 DO ERROR^ORWDXVB2("^TMP(""ORLRC"",$J)")
- End DoDot:1
- QUIT
- +14 SET ORN(2.91)="DIRECT AHG TEST COMMENT"
- SET ORN(8)="ANTIBODY SCREEN COMMENT"
- +15 SET ORN(10.3)="ABO TESTING COMMENT"
- SET ORN(11.3)="RH TESTING COMMENT"
- +16 DO EN^ORWLR2
- +17 QUIT
- REPORT ;Blood Bank Report for M reports menu
- +1 if '$GET(DFN)
- QUIT
- +2 NEW DIC,ID,ORDFN,ORY,PAGE,XQORNOD,ORDAYSBK
- +3 SET ORDFN=DFN
- SET ID=2
- +4 DO BLR^ORWRP1(.ORY,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDAYSBK,.REMOTE)
- +5 if '$LENGTH(ORY)
- QUIT
- +6 SET PAGE=1
- +7 ;D HEAD^ORWRPP1(ORDFN,PAGE,"PATIENT BLOOD BANK REPORT",$G(STATION))
- +8 ;D HURL^ORWRPP1(.ORY,ORDFN,"PATIENT BLOOD BANK REPORT",,,1)
- +9 ;modified lab header to include facility address
- +10 DO LRHEAD^ORWRPP1(ORDFN,PAGE,"PATIENT BLOOD BANK REPORT",$GET(STATION))
- +11 DO LRHURL^ORWRPP1(.ORY,ORDFN,"PATIENT BLOOD BANK REPORT",,,1)
- +12 QUIT
- GETPAT(ERR) ;Setup Patient Variables
- +1 NEW ORPNM
- +2 SET ERR=0
- +3 DO EN2^ORUDPA
- +4 IF 'ORVP
- SET ERR=1
- QUIT
- +5 SET PATID="`"_+ORVP
- SET PATNAM=ORPNM
- SET PATDOB=$PIECE(^DPT(+ORVP,0),"^",3)
- +6 DO PAT^VBECA1A
- +7 WRITE !,LRDFN
- +8 IF $ORDER(VBECERR(0))
- Begin DoDot:1
- +9 SET ERR=0
- FOR
- SET ERR=$ORDER(VBECERR(ERR))
- if 'ERR
- QUIT
- WRITE !?5," ERR:"_VBECERR(1)
- End DoDot:1
- SET ERR=1
- QUIT
- +10 QUIT
- TEST ;Test calls
- +1 NEW ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR,ERROR
- +2 DO GETPAT(.ERROR)
- +3 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +4 DO ABORH
- DO ABID
- DO TRRX
- DO DFN
- DO CPRS
- DO TRAN
- +5 IF $ORDER(^TMP("VBDATA",$JOB,"CROSSMATCH",0))
- Begin DoDot:1
- +6 WRITE !,"Crossmatched Units: "
- SET ID=0
- FOR
- SET ID=$ORDER(^TMP("VBDATA",$JOB,"CROSSMATCH",ID))
- if 'ID
- QUIT
- WRITE !?2,^(ID)
- End DoDot:1
- +7 KILL ^TMP("VBDATA",$JOB),^TMP("TRRX",$JOB),^TMP("TRAN",$JOB)
- +8 QUIT
- OEAPI ;Test call to OEAPI^VBECA3
- +1 NEW DIV,ORSTN,ERROR,ORVB
- +2 DO GETPAT^ORWLR1(.ERROR)
- +3 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +4 SET DIV=+$PIECE($GET(^SC(+$GET(ORL),0)),U,15)
- SET ORSTN=$PIECE($$SITE^VASITE(DT,DIV),U,3)
- +5 DO OEAPI^VBECA3(.ORVB,+ORVP,ORSTN)
- +6 IF $ORDER(ORVB(0))
- Begin DoDot:1
- +7 WRITE !,"Array returned from OEAPI^VBECA3 API in ORVB():",!
- +8 ;ZW ORVB
- End DoDot:1
- +9 KILL ^TMP("OR",$JOB),^TMP("VBECRPC",$JOB),^TMP("VBECS_XML_RES",$JOB),^TMP("VBEC_OE_DATA",$JOB)
- +10 QUIT
- ABORH ;Test call to ABORH^VBECA1 for ABO/Rh - DBIA 3181
- +1 NEW ERROR
- +2 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +3 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +4 SET ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB)
- WRITE !,"ABO/RH: "_ABORH
- +5 QUIT
- ABID ;Test call to ABID^VBECA1 for Antibodies Identified - DBIA 3181, 3184
- +1 NEW ID,ERROR,ORPARNT
- +2 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +3 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +4 DO ABID^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
- IF $ORDER(ARR("ABID",0))
- Begin DoDot:1
- +5 WRITE !,"Antibodies Identified: "
- SET ID=0
- FOR
- SET ID=$ORDER(ARR("ABID",ID))
- if 'ID
- QUIT
- WRITE !?2,ARR("ABID",ID)
- End DoDot:1
- +6 QUIT
- DFN ;Test call to DFN^VBECA3A - DBIA 3879
- +1 NEW ID,ID1,ID2,ERROR
- +2 KILL ^TMP("VBDATA",$JOB)
- +3 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +4 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +5 DO DFN^VBECA3A(DFN)
- +6 IF $ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",0))
- Begin DoDot:1
- +7 WRITE !,"Component request: "
- SET ID=0
- FOR
- SET ID=$ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",ID))
- if 'ID
- QUIT
- WRITE !?2,^(ID)
- Begin DoDot:2
- +8 SET ID1=0
- FOR
- SET ID1=$ORDER(^TMP("VBDATA",$JOB,"COMPONENT REQUEST",ID,ID1))
- if 'ID1
- QUIT
- WRITE !,"."_^(ID1)
- End DoDot:2
- End DoDot:1
- +9 IF $ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",0))
- Begin DoDot:1
- +10 WRITE !,"Specimen: "
- SET ID=0
- FOR
- SET ID=$ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",ID))
- if 'ID
- QUIT
- WRITE !?2,^(ID)
- Begin DoDot:2
- +11 SET ID1=0
- FOR
- SET ID1=$ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",ID,ID1))
- if 'ID1
- QUIT
- if $DATA(^(ID1))#2
- WRITE !,"."_^(ID1)
- Begin DoDot:3
- +12 SET ID2=0
- FOR
- SET ID2=$ORDER(^TMP("VBDATA",$JOB,"SPECIMEN",ID,ID1,ID2))
- if 'ID2
- QUIT
- if $DATA(^(ID2))#2
- WRITE !,".."_^(ID2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 IF $ORDER(^TMP("VBDATA",$JOB,"UNIT",0))
- Begin DoDot:1
- +14 WRITE !,"Available Units: "
- +15 SET ID=0
- FOR
- SET ID=$ORDER(^TMP("VBDATA",$JOB,"UNIT",ID))
- if 'ID
- QUIT
- WRITE !?2,^(ID)
- End DoDot:1
- +16 QUIT
- CPRS ;Test call to CPRS^VBECA3B - DBIA 3880
- +1 NEW ID,ID1,ID2,ERROR
- +2 KILL ^TMP("BBD",$JOB)
- +3 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +4 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +5 DO CPRS^VBECA3B
- +6 IF $ORDER(^TMP("BBD",$JOB,"SPECIMEN",0))
- Begin DoDot:1
- +7 WRITE !,"Specimen: "
- SET ID=0
- FOR
- SET ID=$ORDER(^TMP("BBD",$JOB,"SPECIMEN",ID))
- if 'ID
- QUIT
- WRITE !?2,^(ID)
- Begin DoDot:2
- +8 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
- +9 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
- +10 QUIT
- TRAN ;Test call to TRAN^VBECA4 for Tranfused Units - DBIA 3176
- +1 NEW BPN,ID,GMI,GMR,ERROR,CNT,ORAY,COMP,COMPSEQ,X,TD
- +2 KILL ^TMP("TRAN",$JOB),^TMP("ZTRAN",$JOB)
- +3 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +4 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +5 DO TRAN^VBECA4(+ORVP,"TRAN")
- +6 ;^TMP("TRAN",$J,InverseDate)="Date^Number of Units\Product Type"
- +7 ;^TMP("TRAN",$J,"Product Type")="Product Type Print Name"
- +8 SET CNT=0
- FOR ID="RBC","FFP","PLT","CRY","PLA","SER","GRA","WB"
- SET CNT=CNT+1
- SET ORAY(ID)=CNT
- +9 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
- +10 IF '$DATA(^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ))
- SET ^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ)=GMR_"^"_1
- QUIT
- +11 SET CNT=$PIECE(^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ),"^",3)
- SET $PIECE(^(COMPSEQ),"^",3)=CNT+1
- End DoDot:1
- +12 IF $ORDER(^TMP("ZTRAN",$JOB,0))
- Begin DoDot:1
- +13 WRITE !,"Sorted/grouped Transfused Units: ",!
- SET ID=0
- +14 FOR
- SET ID=$ORDER(^TMP("ZTRAN",$JOB,ID))
- if 'ID
- QUIT
- SET COMP=""
- FOR
- SET COMP=$ORDER(^TMP("ZTRAN",$JOB,ID,COMP))
- if COMP=""
- QUIT
- SET GMR=^(COMP)
- Begin DoDot:2
- +15 IF $PIECE(GMR,"^",3)
- SET $PIECE(GMR,"^",2)=$PIECE(GMR,"^",3)_"\"_$PIECE($PIECE(GMR,"^",2),"\",2)
- +16 DO PARSE
- DO WRT
- End DoDot:2
- End DoDot:1
- +17 IF $ORDER(^TMP("TRAN",$JOB,0))
- Begin DoDot:1
- +18 WRITE !,"Transfused Units (from VBECS API): ",!
- SET ID=0
- +19 FOR
- SET ID=$ORDER(^TMP("TRAN",$JOB,ID))
- if 'ID
- QUIT
- SET GMR=^(ID)
- Begin DoDot:2
- +20 DO PARSE
- DO WRT
- End DoDot:2
- +21 IF $ORDER(^TMP("TRAN",$JOB,"A"))'=""
- Begin DoDot:2
- +22 WRITE !," Blood Product Key: "
- End DoDot:2
- +23 SET GMI="A"
- FOR
- SET GMI=$ORDER(^TMP("TRAN",$JOB,GMI))
- if GMI=""
- QUIT
- Begin DoDot:2
- +24 WRITE ?22,GMI," = ",$GET(^TMP("TRAN",$JOB,GMI)),!
- End DoDot:2
- End DoDot:1
- +25 QUIT
- TRRX ;Test call to TRRX^VBECA1 for Transfusion Reactions - DBIA 3181, 3187
- +1 NEW ARR,ID,ERROR,ORPARNT
- +2 IF '$GET(ORVP)
- DO GETPAT(.ERROR)
- +3 IF $GET(ERROR)
- WRITE !,"Error on Patient lookup"
- QUIT
- +4 DO TRRX^VBECA1(PATID,PATNAM,PATDOB,.ORPARNT,.ORARR)
- IF $ORDER(ARR("TRRX",0))
- Begin DoDot:1
- +5 WRITE !,"Transfusion reactions: "
- SET ID=0
- FOR
- SET ID=$ORDER(ARR("TRRX",ID))
- if 'ID
- QUIT
- WRITE !?2,ARR("TRRX",ID)
- End DoDot:1
- +6 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