- LRBLJT ;AVAMC/REG - BB ITEMIZED TRANSACTIONS ;2/18/93 09:32 ;
- ;;5.2;LAB SERVICE;**247,267,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D END S X="T",%DT="" D ^%DT,D^LRU S LRH(0)=Y
- S IOP="HOME" D ^%ZIS W @IOF,?18,"BLOOD PRODUCTS: ITEMIZED TRANSACTIONS LIST"
- D EDC,B^LRU G:Y<0 END
- S LRLDT=LRLDT+.99,LRSDT=LRSDT-.01
- S ZTRTN="QUE^LRBLJT" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S Z=0 D L^LRU,S^LRU
- F B=0:0 S LRSDT=$O(^LRD(65,"A",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F LRA=0:0 S LRA=$O(^LRD(65,"A",LRSDT,LRA)) Q:'LRA I $D(^LRD(65,LRA,0)) S W=^(0) D SET
- D WRT G:LR("Q") OUT W !!,?69,"--------",!,"Total unit count (all components): ",Z,?50,"Total",?60,"cost",?69,$J(Z(1),8,2)
- S LRB=1 D:$Y>(IOSL-6) H G:LR("Q") OUT S A=0 F A(1)=0:0 S A=$O(LRC(A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,A,?5,"= ",$S($D(^LAB(66,LRC(A),0)):$P(^(0),"^"),1:"???")
- OUT K ^TMP($J) D END^LRUTL,END Q
- SET S LRI=$S($P(W,"^",3)]"":$P(W,"^",3),1:"UNKNOWN"),R=$P($P(W,"^",5),".",1),N=$P(W,"^",14),N=$S($P(W,"^",10):$P(W,"^",10),1:$E(N,2,$L(N)))
- S ^TMP($J,$P(W,"^",2),$P(W,"^",4),R,LRI,$P(W,"^"))=$P(W,"^",6)_"^"_$P(W,"^",7)_"^"_$P(W,"^",8)_"^"_N_"^"_$S($D(^LRD(65,LRA,4)):$P(^(4),"^"),1:""),Z=Z+1
- Q
- WRT D H Q:LR("Q") S LR("F")=1,(Z(1),S)=0 F A(1)=1:1 S S=$O(^TMP($J,S)) Q:S=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !!,"Supplier: ",S,! D C
- Q
- C S C=0 F A=0:1 S C=$O(^TMP($J,S,C)) Q:'C!(LR("Q")) S C(1)=$S($D(^LAB(66,C,0)):$P(^(0),"^",2),1:"???"),LRC(C(1))=C D:$Y>(IOSL-6) H1 Q:LR("Q") W !!,C(1) D DATE
- Q
- DATE S (Z(3),Z(5),R)=0 F B=0:1 S R=$O(^TMP($J,S,C,R)) Q:'R!(LR("Q")) S Y=R D D^LRU S R(1)=Y D:$Y>(IOSL-6) H2 Q:LR("Q") W:B ! W ?7,R(1) D L
- Q:LR("Q") W !?69,"--------",!?50,C(1),?60,"cost",?69,$J(Z(3),8,2) Q
- L S L=0 F E=0:1 S L=$O(^TMP($J,S,C,R,L)) Q:L=""!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") W:E ! W ?21,L D U
- Q
- U S L(1)=0 F F=0:1 S L(1)=$O(^TMP($J,S,C,R,L,L(1))) Q:L(1)=""!(LR("Q")) S W=^(L(1)) D FIN
- Q
- FIN S Z(6)=$P(W,"^",4) S:Z(6)'["-" Z(5)=Z(5)+1 D:$Y>(IOSL-6) H3 Q:LR("Q") W:F ! W:Z(6)'["-" ?30,$J(Z(5),5),")" W ?37,L(1),?51,$P(W,"^",2),?53,$E($P(W,"^",3),1)
- S Z(3)=Z(3)+Z(6),Z(1)=Z(1)+Z(6),Y=$P($P(W,"^"),".",1) D D^LRU W ?55,Y,?71,$J(Z(6),6) S V=$P(W,"^",5) W ?78,V Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"BLOOD BANK INVOICES (from ",LRSTR," to ",LRLST,")" I $D(LRB) W !,LR("%") Q
- W !,"COMPONENT",?12,"DATE",?21,"INVOICE#",?30,"COUNT",?37,"UNIT NO",?51,"TYPE",?58,"EXP DATE",?71,"AMOUNT",?78,"D",!,LR("%") Q
- H1 D H Q:LR("Q") W !!,"Supplier: ",S,! Q
- H2 D H1 Q:LR("Q") W !!,C(1) Q
- H3 D H2 Q:LR("Q") W ?10,R(1) Q
- EDC W ! W "Edit supplier charges before listing invoices? NO// " R X:DTIME Q:X=""!(X[U)!(X?1"N".E) G EDC:X'?1"Y".E
- N S (DIC,DIE)=65,DIC(0)="AEFQM",DIC("A")="Select donor unit: " D ^DIC K DIC Q:X=""!(X[U) S DA=+Y,DR=".1;.13;.14" D ^DIE K DIC,DIE,DR,DA,DQ G N
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJT 2950 printed Feb 18, 2025@23:37:21 Page 2
- LRBLJT ;AVAMC/REG - BB ITEMIZED TRANSACTIONS ;2/18/93 09:32 ;
- +1 ;;5.2;LAB SERVICE;**247,267,408**;Sep 27, 1994;Build 8
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 QUIT
- DO END
- SET X="T"
- SET %DT=""
- DO ^%DT
- DO D^LRU
- SET LRH(0)=Y
- +4 SET IOP="HOME"
- DO ^%ZIS
- WRITE @IOF,?18,"BLOOD PRODUCTS: ITEMIZED TRANSACTIONS LIST"
- +5 DO EDC
- DO B^LRU
- if Y<0
- GOTO END
- +6 SET LRLDT=LRLDT+.99
- SET LRSDT=LRSDT-.01
- +7 SET ZTRTN="QUE^LRBLJT"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET Z=0
- DO L^LRU
- DO S^LRU
- +1 FOR B=0:0
- SET LRSDT=$ORDER(^LRD(65,"A",LRSDT))
- if 'LRSDT!(LRSDT>LRLDT)
- QUIT
- FOR LRA=0:0
- SET LRA=$ORDER(^LRD(65,"A",LRSDT,LRA))
- if 'LRA
- QUIT
- IF $DATA(^LRD(65,LRA,0))
- SET W=^(0)
- DO SET
- +2 DO WRT
- if LR("Q")
- GOTO OUT
- WRITE !!,?69,"--------",!,"Total unit count (all components): ",Z,?50,"Total",?60,"cost",?69,$JUSTIFY(Z(1),8,2)
- +3 SET LRB=1
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- GOTO OUT
- SET A=0
- FOR A(1)=0:0
- SET A=$ORDER(LRC(A))
- if A=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !,A,?5,"= ",$SELECT($DATA(^LAB(66,LRC(A),0)):$PIECE(^(0),"^"),1:"???")
- OUT KILL ^TMP($JOB)
- DO END^LRUTL
- DO END
- QUIT
- SET SET LRI=$SELECT($PIECE(W,"^",3)]"":$PIECE(W,"^",3),1:"UNKNOWN")
- SET R=$PIECE($PIECE(W,"^",5),".",1)
- SET N=$PIECE(W,"^",14)
- SET N=$SELECT($PIECE(W,"^",10):$PIECE(W,"^",10),1:$EXTRACT(N,2,$LENGTH(N)))
- +1 SET ^TMP($JOB,$PIECE(W,"^",2),$PIECE(W,"^",4),R,LRI,$PIECE(W,"^"))=$PIECE(W,"^",6)_"^"_$PIECE(W,"^",7)_"^"_$PIECE(W,"^",8)_"^"_N_"^"_$SELECT($DATA(^LRD(65,LRA,4)):$PIECE(^(4),"^"),1:"")
- SET Z=Z+1
- +2 QUIT
- WRT DO H
- if LR("Q")
- QUIT
- SET LR("F")=1
- SET (Z(1),S)=0
- FOR A(1)=1:1
- SET S=$ORDER(^TMP($JOB,S))
- if S=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !!,"Supplier: ",S,!
- DO C
- +1 QUIT
- C SET C=0
- FOR A=0:1
- SET C=$ORDER(^TMP($JOB,S,C))
- if 'C!(LR("Q"))
- QUIT
- SET C(1)=$SELECT($DATA(^LAB(66,C,0)):$PIECE(^(0),"^",2),1:"???")
- SET LRC(C(1))=C
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- WRITE !!,C(1)
- DO DATE
- +1 QUIT
- DATE SET (Z(3),Z(5),R)=0
- FOR B=0:1
- SET R=$ORDER(^TMP($JOB,S,C,R))
- if 'R!(LR("Q"))
- QUIT
- SET Y=R
- DO D^LRU
- SET R(1)=Y
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- if B
- WRITE !
- WRITE ?7,R(1)
- DO L
- +1 if LR("Q")
- QUIT
- WRITE !?69,"--------",!?50,C(1),?60,"cost",?69,$JUSTIFY(Z(3),8,2)
- QUIT
- L SET L=0
- FOR E=0:1
- SET L=$ORDER(^TMP($JOB,S,C,R,L))
- if L=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H3
- if LR("Q")
- QUIT
- if E
- WRITE !
- WRITE ?21,L
- DO U
- +1 QUIT
- U SET L(1)=0
- FOR F=0:1
- SET L(1)=$ORDER(^TMP($JOB,S,C,R,L,L(1)))
- if L(1)=""!(LR("Q"))
- QUIT
- SET W=^(L(1))
- DO FIN
- +1 QUIT
- FIN SET Z(6)=$PIECE(W,"^",4)
- if Z(6)'["-"
- SET Z(5)=Z(5)+1
- if $Y>(IOSL-6)
- DO H3
- if LR("Q")
- QUIT
- if F
- WRITE !
- if Z(6)'["-"
- WRITE ?30,$JUSTIFY(Z(5),5),")"
- WRITE ?37,L(1),?51,$PIECE(W,"^",2),?53,$EXTRACT($PIECE(W,"^",3),1)
- +1 SET Z(3)=Z(3)+Z(6)
- SET Z(1)=Z(1)+Z(6)
- SET Y=$PIECE($PIECE(W,"^"),".",1)
- DO D^LRU
- WRITE ?55,Y,?71,$JUSTIFY(Z(6),6)
- SET V=$PIECE(W,"^",5)
- WRITE ?78,V
- QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"BLOOD BANK INVOICES (from ",LRSTR," to ",LRLST,")"
- IF $DATA(LRB)
- WRITE !,LR("%")
- QUIT
- +2 WRITE !,"COMPONENT",?12,"DATE",?21,"INVOICE#",?30,"COUNT",?37,"UNIT NO",?51,"TYPE",?58,"EXP DATE",?71,"AMOUNT",?78,"D",!,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !!,"Supplier: ",S,!
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- WRITE !!,C(1)
- QUIT
- H3 DO H2
- if LR("Q")
- QUIT
- WRITE ?10,R(1)
- QUIT
- EDC WRITE !
- WRITE "Edit supplier charges before listing invoices? NO// "
- READ X:DTIME
- if X=""!(X[U)!(X?1"N".E)
- QUIT
- if X'?1"Y".E
- GOTO EDC
- N SET (DIC,DIE)=65
- SET DIC(0)="AEFQM"
- SET DIC("A")="Select donor unit: "
- DO ^DIC
- KILL DIC
- if X=""!(X[U)
- QUIT
- SET DA=+Y
- SET DR=".1;.13;.14"
- DO ^DIE
- KILL DIC,DIE,DR,DA,DQ
- GOTO N
- +1 ;
- END DO V^LRU
- QUIT
