- LRBLTA ;AVAMC/REG - TRANSFUSION REACTION COUNTS ;7/2/93 07:05 ;
- ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D END,B^LRU G:Y<0 END W !!,"List patients " S %=2,LRF=0 D YN^LRU G:%<1 END S:%=1 LRF=1 W !
- S ZTRTN="QUE^LRBLTA" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S LRSDT=9999998.9-LRSDT,LRLDT=9999997.9-LRLDT
- D L^LRU,S^LRU,H S LR("F")=1
- F LRDFN=0:0 S LRDFN=$O(^LR("AB",LRDFN)) Q:'LRDFN F LRR=0:0 S LRR=$O(^LR("AB",LRDFN,LRR)) Q:'LRR F LRI=LRLDT:0 S LRI=$O(^LR("AB",LRDFN,LRR,LRI)) Q:'LRI!(LRI>LRSDT) D S
- F LRR=0:0 S LRR=$O(^TMP($J,LRR)) Q:'LRR!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") S LRR(1)=$P(^LAB(65.4,LRR,0),U) W !!,LRR(1),?31,$J(^TMP($J,LRR),4) D A
- G:LR("Q") OUT W ! S A=0 F S A=$O(^TMP($J,"B",A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,A,?5,"= ",^TMP($J,"B",A)
- OUT D:'LR("Q") ^LRBLTA1 D END^LRUTL,END Q
- S S X=$G(^LR(LRDFN,1.6,LRI,0)),C=$P(X,"^",2) Q:'C
- S:'$D(^TMP($J,LRR)) ^(LRR)=0 S ^(LRR)=^(LRR)+1
- S:'$D(^TMP($J,LRR,C)) ^(C)=0 S ^(C)=^(C)+1 S:LRF ^(C,LRDFN,LRI)=+X_"^"_$P(X,"^",3) Q
- A F LRC=0:0 S LRC=$O(^TMP($J,LRR,LRC)) Q:'LRC!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") S LRE=$P(^LAB(66,LRC,0),U,2) S:LRE]"" ^TMP($J,"B",LRE)=$P(^(0),U) W !?41,LRE,?51,$J(^TMP($J,LRR,LRC),4) D:LRF B
- Q
- B S LRDFN=0 F S LRDFN=$O(^TMP($J,LRR,LRC,LRDFN)) Q:'LRDFN!(LR("Q")) D N,C
- Q
- C S LRI=0 F S LRI=$O(^TMP($J,LRR,LRC,LRDFN,LRI)) Q:'LRI!(LR("Q")) S LRX=^(LRI) D:$Y>(IOSL-6) H2 Q:LR("Q") W !,SSN,?5,LRP,?36 S Y=+LRX D DT^LRU W Y,?67,$P(LRX,"^",2)
- Q
- N S X=^LR(LRDFN,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$E($P(X,"^",9),6,9) Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"TRANSFUSION REACTION COUNTS FROM ",LRSTR," TO ",LRLST,!,"REACTION",?31,"COUNT",?41,"COMPONENT",?51,"SUBCOUNT" W:LRF !,"SSN",?5,"Patient",?36,"Transfusion Date",?67,"Unit ID" W !,LR("%") Q
- H1 D H Q:LR("Q") W !,LRR(1) Q
- H2 D H1 Q:LR("Q") W ?41,LRE Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLTA 2037 printed Jan 18, 2025@03:13:03 Page 2
- LRBLTA ;AVAMC/REG - TRANSFUSION REACTION COUNTS ;7/2/93 07:05 ;
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- DO B^LRU
- if Y<0
- GOTO END
- WRITE !!,"List patients "
- SET %=2
- SET LRF=0
- DO YN^LRU
- if %<1
- GOTO END
- if %=1
- SET LRF=1
- WRITE !
- +4 SET ZTRTN="QUE^LRBLTA"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET LRSDT=9999998.9-LRSDT
- SET LRLDT=9999997.9-LRLDT
- +1 DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- +2 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR("AB",LRDFN))
- if 'LRDFN
- QUIT
- FOR LRR=0:0
- SET LRR=$ORDER(^LR("AB",LRDFN,LRR))
- if 'LRR
- QUIT
- FOR LRI=LRLDT:0
- SET LRI=$ORDER(^LR("AB",LRDFN,LRR,LRI))
- if 'LRI!(LRI>LRSDT)
- QUIT
- DO S
- +3 FOR LRR=0:0
- SET LRR=$ORDER(^TMP($JOB,LRR))
- if 'LRR!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- SET LRR(1)=$PIECE(^LAB(65.4,LRR,0),U)
- WRITE !!,LRR(1),?31,$JUSTIFY(^TMP($JOB,LRR),4)
- DO A
- +4 if LR("Q")
- GOTO OUT
- WRITE !
- SET A=0
- FOR
- SET A=$ORDER(^TMP($JOB,"B",A))
- if A=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !,A,?5,"= ",^TMP($JOB,"B",A)
- OUT if 'LR("Q")
- DO ^LRBLTA1
- DO END^LRUTL
- DO END
- QUIT
- S SET X=$GET(^LR(LRDFN,1.6,LRI,0))
- SET C=$PIECE(X,"^",2)
- if 'C
- QUIT
- +1 if '$DATA(^TMP($JOB,LRR))
- SET ^(LRR)=0
- SET ^(LRR)=^(LRR)+1
- +2 if '$DATA(^TMP($JOB,LRR,C))
- SET ^(C)=0
- SET ^(C)=^(C)+1
- if LRF
- SET ^(C,LRDFN,LRI)=+X_"^"_$PIECE(X,"^",3)
- QUIT
- A FOR LRC=0:0
- SET LRC=$ORDER(^TMP($JOB,LRR,LRC))
- if 'LRC!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- SET LRE=$PIECE(^LAB(66,LRC,0),U,2)
- if LRE]""
- SET ^TMP($JOB,"B",LRE)=$PIECE(^(0),U)
- WRITE !?41,LRE,?51,$JUSTIFY(^TMP($JOB,LRR,LRC),4)
- if LRF
- DO B
- +1 QUIT
- B SET LRDFN=0
- FOR
- SET LRDFN=$ORDER(^TMP($JOB,LRR,LRC,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- DO N
- DO C
- +1 QUIT
- C SET LRI=0
- FOR
- SET LRI=$ORDER(^TMP($JOB,LRR,LRC,LRDFN,LRI))
- if 'LRI!(LR("Q"))
- QUIT
- SET LRX=^(LRI)
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !,SSN,?5,LRP,?36
- SET Y=+LRX
- DO DT^LRU
- WRITE Y,?67,$PIECE(LRX,"^",2)
- +1 QUIT
- N SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET X=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET X=@(X_Y_",0)")
- SET LRP=$PIECE(X,"^")
- SET SSN=$EXTRACT($PIECE(X,"^",9),6,9)
- QUIT
- +1 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"TRANSFUSION REACTION COUNTS FROM ",LRSTR," TO ",LRLST,!,"REACTION",?31,"COUNT",?41,"COMPONENT",?51,"SUBCOUNT"
- if LRF
- WRITE !,"SSN",?5,"Patient",?36,"Transfusion Date",?67,"Unit ID"
- WRITE !,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !,LRR(1)
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- WRITE ?41,LRE
- QUIT
- +1 ;
- END DO V^LRU
- QUIT