ORWLR1 ; slc/dcm - VBEC Blood Bank Report ;01/16/03 15:02
;;3.0;ORDER ENTRY/RESULTS REPORTING;**172**;Dec 17, 1997
;Re-write of ^LR7OSBR
EN(DFN) ;Get Blood Bank Report
Q:'$G(DFN)
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
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
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)
Q
TEST ;Test calls
N ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR
D EN2^ORUDPA
Q:'ORVP
K ^TMP("BBD",$J),^TMP("TRRX",$J),^TMP("TRAN",$J)
S PATID="`"_+ORVP,PATNAM=ORPNM,PATDOB=$P(^DPT(+ORVP,0),"^",3)
D PAT^VBECA1A W !,LRDFN I $O(VBECERR(0)) S ERR=0 F S ERR=$O(VBECERR(ERR)) Q:'ERR W !?5," ERR:"_VBECERR(1)
S ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB) W !,"ABO/RH: "_ABORH
D ABID^VBECA1(PATID,PATNAM,PATDOB,.PARENT,.ARR) 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)
D TRRX^VBECA1(PATID,PATNAM,PATDOB,.PARENT,.ARR) 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)
D DFN^VBECA3A(DFN),CPRS^VBECA3B
I $O(^TMP("BBD",$J,"CROSSMATCH",0)) D
. W !,"Crossmatched Units: " S ID=0 F S ID=$O(^TMP("BBD",$J,"CROSSMATCH",ID)) Q:'ID W !?2,^(ID)
I $O(^TMP("BBD",$J,"COMPONENT REQUEST",0)) D
. W !,"Component request: " S ID=0 F S ID=$O(^TMP("BBD",$J,"COMPONENT REQUEST",ID)) Q:'ID W !?2,^(ID) D
.. S ID1=0 F S ID1=$O(^TMP("BBD",$J,"COMPONENT REQUEST",ID,ID1)) Q:'ID1 W !,"."_^(ID1)
D TRAN^VBECA4(+ORVP,"TRAN")
I $O(^TMP("TRAN",$J,0)) D
. N ID,GMR,GMA
. W !,"Transfused Units: ",! 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 !
.. W " Blood Product Key: "
. S GMI="A" F S GMI=$O(^TMP("TRAN",$J,GMI)) Q:GMI="" D
.. W ?21,GMI," = ",$G(^TMP("TRAN",$J,GMI)),!
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)
K ^TMP("BBD",$J),^TMP("TRRX",$J),^TMP("TRAN",$J)
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
ORWLR1 ; slc/dcm - VBEC Blood Bank Report ;01/16/03 15:02
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**172**;Dec 17, 1997
+2 ;Re-write of ^LR7OSBR
EN(DFN) ;Get Blood Bank Report
+1 IF '$GET(DFN)
QUIT
+2 NEW GCNT,CCNT,GIOSL,GIOM,ORABORH,PATID,PATNAM,PATDOB,ORN
+3 ;Why PATNAM and PATDOB???
SET PATID="`"_DFN
SET PATNAM=$PIECE(^DPT(DFN,0),"^")
SET PATDOB=$PIECE(^(0),"^",3)
+4 KILL ^TMP("ORLRC",$JOB)
+5 SET GCNT=0
SET CCNT=1
SET GIOSL=999999
SET GIOM=80
+6 ;Get ABO/RH
SET ORABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB)
+7 SET ORN(2.91)="DIRECT AHG TEST COMMENT"
SET ORN(8)="ANTIBODY SCREEN COMMENT"
+8 SET ORN(10.3)="ABO TESTING COMMENT"
SET ORN(11.3)="RH TESTING COMMENT"
+9 DO EN^ORWLR2
+10 QUIT
+11 ;
REPORT ;Blood Bank Report for M reports menu
+1 IF '$GET(DFN)
QUIT
+2 NEW DIC,ID,ORDFN,ORY,PAGE,XQORNOD
+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 DO HEAD^ORWRPP1(ORDFN,PAGE,"PATIENT BLOOD BANK REPORT",$GET(STATION))
+8 DO HURL^ORWRPP1(.ORY,ORDFN,"PATIENT BLOOD BANK REPORT",,,1)
+9 QUIT
TEST ;Test calls
+1 NEW ORVP,PATID,PATNAM,PATDOB,LRDFN,ERR,ABORH,ID,ID1,ID2,ARR,GMI,DI2,BPN,VBECERR
+2 DO EN2^ORUDPA
+3 IF 'ORVP
QUIT
+4 KILL ^TMP("BBD",$JOB),^TMP("TRRX",$JOB),^TMP("TRAN",$JOB)
+5 SET PATID="`"_+ORVP
SET PATNAM=ORPNM
SET PATDOB=$PIECE(^DPT(+ORVP,0),"^",3)
+6 DO PAT^VBECA1A
WRITE !,LRDFN
IF $ORDER(VBECERR(0))
SET ERR=0
FOR
SET ERR=$ORDER(VBECERR(ERR))
IF 'ERR
QUIT
WRITE !?5," ERR:"_VBECERR(1)
+7 SET ABORH=$$ABORH^VBECA1(PATID,PATNAM,PATDOB)
WRITE !,"ABO/RH: "_ABORH
+8 DO ABID^VBECA1(PATID,PATNAM,PATDOB,.PARENT,.ARR)
IF $ORDER(ARR("ABID",0))
Begin DoDot:1
+9 WRITE !,"Antibodies Identified: "
SET ID=0
FOR
SET ID=$ORDER(ARR("ABID",ID))
IF 'ID
QUIT
WRITE !?2,ARR("ABID",ID)
End DoDot:1
+10 DO TRRX^VBECA1(PATID,PATNAM,PATDOB,.PARENT,.ARR)
IF $ORDER(ARR("TRRX",0))
Begin DoDot:1
+11 WRITE !,"Transfusion reactions: "
SET ID=0
FOR
SET ID=$ORDER(ARR("TRRX",ID))
IF 'ID
QUIT
WRITE !?2,ARR("TRRX",ID)
End DoDot:1
+12 DO DFN^VBECA3A(DFN)
DO CPRS^VBECA3B
+13 IF $ORDER(^TMP("BBD",$JOB,"CROSSMATCH",0))
Begin DoDot:1
+14 WRITE !,"Crossmatched Units: "
SET ID=0
FOR
SET ID=$ORDER(^TMP("BBD",$JOB,"CROSSMATCH",ID))
IF 'ID
QUIT
WRITE !?2,^(ID)
End DoDot:1
+15 IF $ORDER(^TMP("BBD",$JOB,"COMPONENT REQUEST",0))
Begin DoDot:1
+16 WRITE !,"Component request: "
SET ID=0
FOR
SET ID=$ORDER(^TMP("BBD",$JOB,"COMPONENT REQUEST",ID))
IF 'ID
QUIT
WRITE !?2,^(ID)
Begin DoDot:2
+17 SET ID1=0
FOR
SET ID1=$ORDER(^TMP("BBD",$JOB,"COMPONENT REQUEST",ID,ID1))
IF 'ID1
QUIT
WRITE !,"."_^(ID1)
End DoDot:2
End DoDot:1
+18 DO TRAN^VBECA4(+ORVP,"TRAN")
+19 IF $ORDER(^TMP("TRAN",$JOB,0))
Begin DoDot:1
+20 NEW ID,GMR,GMA
+21 WRITE !,"Transfused Units: ",!
SET ID=0
+22 FOR
SET ID=$ORDER(^TMP("TRAN",$JOB,ID))
IF 'ID
QUIT
SET GMR=^(ID)
Begin DoDot:2
+23 DO PARSE
DO WRT
End DoDot:2
+24 IF $ORDER(^TMP("TRAN",$JOB,"A"))'=""
Begin DoDot:2
+25 WRITE !
+26 WRITE " Blood Product Key: "
End DoDot:2
+27 SET GMI="A"
FOR
SET GMI=$ORDER(^TMP("TRAN",$JOB,GMI))
IF GMI=""
QUIT
Begin DoDot:2
+28 WRITE ?21,GMI," = ",$GET(^TMP("TRAN",$JOB,GMI)),!
End DoDot:2
End DoDot:1
+29 IF $ORDER(^TMP("BBD",$JOB,"SPECIMEN",0))
Begin DoDot:1
+30 WRITE !,"Specimen: "
SET ID=0
FOR
SET ID=$ORDER(^TMP("BBD",$JOB,"SPECIMEN",ID))
IF 'ID
QUIT
WRITE !?2,^(ID)
Begin DoDot:2
+31 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
+32 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
+33 KILL ^TMP("BBD",$JOB),^TMP("TRRX",$JOB),^TMP("TRAN",$JOB)
+34 QUIT
PARSE ;Parse Record
+1 NEW GMI,X
SET TD=$$FMTE^XLFDT(+GMR)
+2 SET GMA(1)=$PIECE(GMR,U,2)
SET BPN=$LENGTH(GMA(1),";")
+3 IF $PIECE(GMA(1),";",BPN)=""
SET BPN=BPN-1
+4 FOR GMI=2:1:BPN
SET GMA(GMI)="("_$PIECE($PIECE(GMA(1),";",GMI),"\")_") "_$PIECE($PIECE(GMA(1),";",GMI),"\",2)
+5 SET GMA(1)="("_$PIECE($PIECE(GMA(1),";",1),"\")_") "_$PIECE($PIECE(GMA(1),";",1),"\",2)
+6 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
