GMTSLRT ; SLC/JER,KER - Blood Bank Transfusion ;AUG 08,2009@14:32
;;2.7;Health Summary;**28,47,59,93,136**;Oct 20, 1995;Build 1
;
; External References
; DBIA 525 ^LR( all fields
; DBIA 2056 $$GET1^DIQ (file 2)
; DBIA 3176 TRAN^VBECA4
;
MAIN ; Blood Transfusion
N GMA,GMI,GMR,IX,MAX,A,R,TD,BPN,LOC
S LOC="LRT",LRDFN=$$GET1^DIQ(2,+($G(DFN)),63,"I")
;
; Get Transfusion Records
; Blood Bank Package TRAN^VBECA4
; Lab Package ^GMTSLRTE
;
K ^TMP("LRT",$J),^TMP("ZTRAN",$J)
S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999),IX=GMTS1
I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface
. D TRAN^VBECA4(DFN,LOC,GMTS1,GMTS2),VBEC,KEY
. D:$$GET^XPAR("DIV^SYS^PKG","OR VBECS LEGACY REPORT",1,"Q") ^GMTSLRTE,TEXT,OLD,KEY
D ^GMTSLRTE,OLD,KEY
TEXT ;
Q:'$D(^TMP("LRT",$J))
W !!?19,"*** [LEGACY VISTA BLOOD BANK REPORT] ***",!
W !?3,"The following historical information comes from the Legacy VISTA Blood"
W !?3,"Bank System. It represents data collected prior to the installation of"
W !?3,"VBECS. Some of the information in this report may have been duplicated"
W !?3,"in the VBECS Blood Transfusion report above (if available).",!
W !?22,"---- Blood Transfusions ----",!
Q
KEY ;
I $O(^TMP("LRT",$J,"A"))'="" D
. D CKP^GMTSUP Q:$D(GMTSQIT) W !
. D CKP^GMTSUP Q:$D(GMTSQIT) W " Blood Product Key: "
S GMI="A" F S GMI=$O(^TMP("LRT",$J,GMI)) Q:GMI="" D
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W ?21,GMI," = ",$G(^TMP("LRT",$J,GMI)),!
K ^TMP("LRT",$J),^TMP("ZTRAN",$J)
Q
VBEC ;VBECS format
Q:'$D(^TMP("LRT",$J))
N ID,GMR,GMA,TD,C,COMP,COMPSEQ,CNT,ORAY
S CNT=0 F ID="RBC","FFP","PLT","CRY","PLA","SER","GRA","WB" S CNT=CNT+1,ORAY(ID)=CNT
S ID=0 F GMI=1:1:MAX S ID=$O(^TMP("LRT",$J,ID)) Q:'ID!(ID>GMTS2) 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 $P(GMR,U,3)=1,^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ)=GMR Q
. S CNT=$P(^TMP("ZTRAN",$J,$P(ID,"."),COMPSEQ),"^",3),$P(^(COMPSEQ),"^",3)=CNT+1
I $O(^TMP("ZTRAN",$J,0)) D
. 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,WRT1
Q
OLD ;Pre-VBECS format
Q:'$D(^TMP("LRT",$J))
F GMI=1:1:MAX S IX=$O(^TMP("LRT",$J,IX)) Q:IX=""!(IX>GMTS2) D
. S GMR=^TMP("LRT",$J,IX) D PRSREC,WRT
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
WRT1 ;Writes VBECS transfusion record for each day
N GML,GMI1,GMI2,GMM,GMJ,CL
S GMM=$S(BPN#4:1,1:0),GML=BPN\4+GMM ;D LN
D CKP^GMTSUP Q:$D(GMTSQIT) 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,CL=(((GMI2-1)*15)+14)
.. W ?CL,GMA(GMJ)
.. I $S(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0) W ! ;D LN
Q
PRSREC ; Parses Record for presentation
N GMI,X
S X=$P(GMR,U) D REGDT4^GMTSU S TD=X
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
D CKP^GMTSUP Q:$D(GMTSQIT) W TD
F GMI1=1:1:GML D Q:$D(GMTSQIT)
. F GMI2=1:1:($S((GMI1=GML)&(BPN#4):BPN#4,1:4)) D Q:$D(GMTSQIT)
.. S GMJ=((GMI1-1)*4)+GMI2 D CKP^GMTSUP Q:$D(GMTSQIT)
.. W ?(((GMI2-1)*15)+10),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[HGMTSLRT 4081 printed Sep 23, 2025@19:34:04 Page 2
GMTSLRT ; SLC/JER,KER - Blood Bank Transfusion ;AUG 08,2009@14:32
+1 ;;2.7;Health Summary;**28,47,59,93,136**;Oct 20, 1995;Build 1
+2 ;
+3 ; External References
+4 ; DBIA 525 ^LR( all fields
+5 ; DBIA 2056 $$GET1^DIQ (file 2)
+6 ; DBIA 3176 TRAN^VBECA4
+7 ;
MAIN ; Blood Transfusion
+1 NEW GMA,GMI,GMR,IX,MAX,A,R,TD,BPN,LOC
+2 SET LOC="LRT"
SET LRDFN=$$GET1^DIQ(2,+($GET(DFN)),63,"I")
+3 ;
+4 ; Get Transfusion Records
+5 ; Blood Bank Package TRAN^VBECA4
+6 ; Lab Package ^GMTSLRTE
+7 ;
+8 KILL ^TMP("LRT",$JOB),^TMP("ZTRAN",$JOB)
+9 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:999)
SET IX=GMTS1
+10 ;Transition to VBEC's interface
IF $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q")
IF $LENGTH($TEXT(EN^ORWLR1))
IF $LENGTH($TEXT(CPRS^VBECA3B))
Begin DoDot:1
+11 DO TRAN^VBECA4(DFN,LOC,GMTS1,GMTS2)
DO VBEC
DO KEY
+12 if $$GET^XPAR("DIV^SYS^PKG","OR VBECS LEGACY REPORT",1,"Q")
DO ^GMTSLRTE
DO TEXT
DO OLD
DO KEY
End DoDot:1
QUIT
+13 DO ^GMTSLRTE
DO OLD
DO KEY
TEXT ;
+1 if '$DATA(^TMP("LRT",$JOB))
QUIT
+2 WRITE !!?19,"*** [LEGACY VISTA BLOOD BANK REPORT] ***",!
+3 WRITE !?3,"The following historical information comes from the Legacy VISTA Blood"
+4 WRITE !?3,"Bank System. It represents data collected prior to the installation of"
+5 WRITE !?3,"VBECS. Some of the information in this report may have been duplicated"
+6 WRITE !?3,"in the VBECS Blood Transfusion report above (if available).",!
+7 WRITE !?22,"---- Blood Transfusions ----",!
+8 QUIT
KEY ;
+1 IF $ORDER(^TMP("LRT",$JOB,"A"))'=""
Begin DoDot:1
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE " Blood Product Key: "
End DoDot:1
+4 SET GMI="A"
FOR
SET GMI=$ORDER(^TMP("LRT",$JOB,GMI))
if GMI=""
QUIT
Begin DoDot:1
+5 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+6 WRITE ?21,GMI," = ",$GET(^TMP("LRT",$JOB,GMI)),!
End DoDot:1
+7 KILL ^TMP("LRT",$JOB),^TMP("ZTRAN",$JOB)
+8 QUIT
VBEC ;VBECS format
+1 if '$DATA(^TMP("LRT",$JOB))
QUIT
+2 NEW ID,GMR,GMA,TD,C,COMP,COMPSEQ,CNT,ORAY
+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 GMI=1:1:MAX
SET ID=$ORDER(^TMP("LRT",$JOB,ID))
if 'ID!(ID>GMTS2)
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 $PIECE(GMR,U,3)=1
SET ^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ)=GMR
QUIT
+6 SET CNT=$PIECE(^TMP("ZTRAN",$JOB,$PIECE(ID,"."),COMPSEQ),"^",3)
SET $PIECE(^(COMPSEQ),"^",3)=CNT+1
End DoDot:1
+7 IF $ORDER(^TMP("ZTRAN",$JOB,0))
Begin DoDot:1
+8 SET ID=0
+9 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
+10 IF $PIECE(GMR,"^",3)
SET $PIECE(GMR,"^",2)=$PIECE(GMR,"^",3)_"\"_$PIECE($PIECE(GMR,"^",2),"\",2)
+11 DO PARSE
DO WRT1
End DoDot:2
End DoDot:1
+12 QUIT
OLD ;Pre-VBECS format
+1 if '$DATA(^TMP("LRT",$JOB))
QUIT
+2 FOR GMI=1:1:MAX
SET IX=$ORDER(^TMP("LRT",$JOB,IX))
if IX=""!(IX>GMTS2)
QUIT
Begin DoDot:1
+3 SET GMR=^TMP("LRT",$JOB,IX)
DO PRSREC
DO WRT
End DoDot:1
+4 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
WRT1 ;Writes VBECS transfusion record for each day
+1 NEW GML,GMI1,GMI2,GMM,GMJ,CL
+2 ;D LN
SET GMM=$SELECT(BPN#4:1,1:0)
SET GML=BPN\4+GMM
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
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
SET CL=(((GMI2-1)*15)+14)
+7 WRITE ?CL,GMA(GMJ)
+8 ;D LN
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
PRSREC ; Parses Record for presentation
+1 NEW GMI,X
+2 SET X=$PIECE(GMR,U)
DO REGDT4^GMTSU
SET TD=X
+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 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
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
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+7 WRITE ?(((GMI2-1)*15)+10),GMA(GMJ)
+8 IF $SELECT(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0)
WRITE !
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+9 QUIT
