- LRBLJSH ;AVAMC/REG - BB INVENTORY SHIPMENTS ;2/18/93 09:31 ;
- ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D END S:'$D(DTIME) DTIME=300 S LRI=$O(^LAB(65.9,"B","SHIPPING INVOICE",0)) I 'LRI W $C(7),!!,"SHIPPING INVOICE must be an entry in the LAB LETTER FILE (65.9)." G END
- S IOP="HOME" D ^%ZIS W @IOF,?18,"INVOICE FOR SHIPMENT OF BLOOD COMPONENTS"
- D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.01
- I R !!,"Enter SHIPPING INVOICE#: ",X:DTIME G:X[U!(X="") END S LRB=X X $P(^DD(65,.13,0),U,5,99) S:'$D(X) X="?" I X["?" W $C(7)," Enter invoice # (2-10 characters)" G I
- A R !!,"Enter name to appear on invoice: ",X:DTIME G:X[U END D CK G:'$D(X) A S LR=X I X="" W $C(7)," Must have a name. Enter '^' to quit" G A
- B R !!,"Enter address line 1: ",X:DTIME G:X[U END D CK G:'$D(X) B S LR(1)=X
- C R !,"Enter address line 2: ",X:DTIME G:X[U END D CK G:'$D(X) C S LR(2)=X
- D R !,"Enter address line 3: ",X:DTIME G:X[U END D CK G:'$D(X) D S LR(3)=X
- S ZTRTN="QUE^LRBLJSH" 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,"AB",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F LRA=0:0 S LRA=$O(^LRD(65,"AB",LRSDT,LRA)) Q:'LRA I $D(^LRD(65,LRA,0)),$P(^(0),"^",13)=LRB S W=^(0) D SET
- D WRT D:$Y>(IOSL-6) H Q:LR("Q") W !,LR("%"),!,"Total unit count (all components): ",Z K ^TMP($J)
- D E,END,END^LRUTL Q
- SET S ^TMP($J,$P(W,"^",4),$P(W,"^",7),$P(W,"^",8),$P(W,"^"))=$P(W,"^",6)_"^"_LRA Q
- WRT D H1 Q:LR("Q") S LR("F")=1 F C=0:0 S C=$O(^TMP($J,C)) Q:'C!(LR("Q")) S V=0 D:$Y>(IOSL-6) H1 Q:LR("Q") W !!,"Component: " S C(1)=^LAB(66,C,0),C(20)=$P(C(1),"^",20),C(1)=$P(C(1),"^") W C(1) W:C(20)]"" " (",C(20),")" D ABO
- Q
- ABO S A=0 F B=0:1 S A=$O(^TMP($J,C,A)) Q:A=""!(LR("Q")) S R=0 F E=0:0 S R=$O(^TMP($J,C,A,R)) Q:R=""!(LR("Q")) S I=0 F F=0:0 S I=$O(^TMP($J,C,A,R,I)) Q:I=""!(LR("Q")) S W=^(I) D W
- Q
- W D:$Y>(IOSL-6) H2 Q:LR("Q") S V=V+1,Z=Z+1,Y=+W D D^LRU W !,$J(V,5) W:$P($G(^LRD(65,+$P(W,"^",2),8)),"^",2) " Pos/Incomplete Tests" W ?28,$J(A,2),?32,R,?38,I,?53,Y Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"BLOOD BANK",?21,"SHIPPING INVOICE#: ",LRB,!?21,"To: ",LR F X=0:0 S X=$O(LR(X)) Q:'X W:LR(X)]"" !?25,LR(X)
- Q
- H1 D H Q:LR("Q") W !?28,"ABO",?32,"Rh",?38,"UNIT ID",?53,"Expiration date",!,LR("%") Q
- H2 D H1 Q:LR("Q") W !!,"Component: ",C(1) W:C(20)]"" " (",C(20),")" W ! Q
- H3 D H Q:LR("Q") W !,LR("%"),!!! Q
- ;
- CK I $L(X)>30!(X'?.ANP)!(X["?") W !,$C(7),"Entry must be less than 31 characters with no control characters." K X
- Q
- E D:$Y>(IOSL-6) H Q:LR("Q") K ^TMP($J) W !,LR("%") S X=^LAB(65.9,LRI,0),DIWL=$P(X,U,5),DIWR=IOM-$P(X,U,6),DIWF="W"
- S LRA=0 F LRZ=0:1 S LRA=$O(^LAB(65.9,LRI,2,LRA)) Q:'LRA!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") S X=^LAB(65.9,LRI,2,LRA,0) D ^DIWP
- Q:LR("Q") D:LRZ ^DIWW Q
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJSH 2911 printed Jan 18, 2025@03:12:10 Page 2
- LRBLJSH ;AVAMC/REG - BB INVENTORY SHIPMENTS ;2/18/93 09:31 ;
- +1 ;;5.2;LAB SERVICE;**247,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
- if '$DATA(DTIME)
- SET DTIME=300
- SET LRI=$ORDER(^LAB(65.9,"B","SHIPPING INVOICE",0))
- IF 'LRI
- WRITE $CHAR(7),!!,"SHIPPING INVOICE must be an entry in the LAB LETTER FILE (65.9)."
- GOTO END
- +4 SET IOP="HOME"
- DO ^%ZIS
- WRITE @IOF,?18,"INVOICE FOR SHIPMENT OF BLOOD COMPONENTS"
- +5 DO B^LRU
- if Y<0
- GOTO END
- SET LRLDT=LRLDT+.99
- SET LRSDT=LRSDT-.01
- I READ !!,"Enter SHIPPING INVOICE#: ",X:DTIME
- if X[U!(X="")
- GOTO END
- SET LRB=X
- XECUTE $PIECE(^DD(65,.13,0),U,5,99)
- if '$DATA(X)
- SET X="?"
- IF X["?"
- WRITE $CHAR(7)," Enter invoice # (2-10 characters)"
- GOTO I
- A READ !!,"Enter name to appear on invoice: ",X:DTIME
- if X[U
- GOTO END
- DO CK
- if '$DATA(X)
- GOTO A
- SET LR=X
- IF X=""
- WRITE $CHAR(7)," Must have a name. Enter '^' to quit"
- GOTO A
- B READ !!,"Enter address line 1: ",X:DTIME
- if X[U
- GOTO END
- DO CK
- if '$DATA(X)
- GOTO B
- SET LR(1)=X
- C READ !,"Enter address line 2: ",X:DTIME
- if X[U
- GOTO END
- DO CK
- if '$DATA(X)
- GOTO C
- SET LR(2)=X
- D READ !,"Enter address line 3: ",X:DTIME
- if X[U
- GOTO END
- DO CK
- if '$DATA(X)
- GOTO D
- SET LR(3)=X
- +1 SET ZTRTN="QUE^LRBLJSH"
- 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,"AB",LRSDT))
- if 'LRSDT!(LRSDT>LRLDT)
- QUIT
- FOR LRA=0:0
- SET LRA=$ORDER(^LRD(65,"AB",LRSDT,LRA))
- if 'LRA
- QUIT
- IF $DATA(^LRD(65,LRA,0))
- IF $PIECE(^(0),"^",13)=LRB
- SET W=^(0)
- DO SET
- +2 DO WRT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !,LR("%"),!,"Total unit count (all components): ",Z
- KILL ^TMP($JOB)
- +3 DO E
- DO END
- DO END^LRUTL
- QUIT
- SET SET ^TMP($JOB,$PIECE(W,"^",4),$PIECE(W,"^",7),$PIECE(W,"^",8),$PIECE(W,"^"))=$PIECE(W,"^",6)_"^"_LRA
- QUIT
- WRT DO H1
- if LR("Q")
- QUIT
- SET LR("F")=1
- FOR C=0:0
- SET C=$ORDER(^TMP($JOB,C))
- if 'C!(LR("Q"))
- QUIT
- SET V=0
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- WRITE !!,"Component: "
- SET C(1)=^LAB(66,C,0)
- SET C(20)=$PIECE(C(1),"^",20)
- SET C(1)=$PIECE(C(1),"^")
- WRITE C(1)
- if C(20)]""
- WRITE " (",C(20),")"
- DO ABO
- +1 QUIT
- ABO SET A=0
- FOR B=0:1
- SET A=$ORDER(^TMP($JOB,C,A))
- if A=""!(LR("Q"))
- QUIT
- SET R=0
- FOR E=0:0
- SET R=$ORDER(^TMP($JOB,C,A,R))
- if R=""!(LR("Q"))
- QUIT
- SET I=0
- FOR F=0:0
- SET I=$ORDER(^TMP($JOB,C,A,R,I))
- if I=""!(LR("Q"))
- QUIT
- SET W=^(I)
- DO W
- +1 QUIT
- W if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET V=V+1
- SET Z=Z+1
- SET Y=+W
- DO D^LRU
- WRITE !,$JUSTIFY(V,5)
- if $PIECE($GET(^LRD(65,+$PIECE(W,"^",2),8)),"^",2)
- WRITE " Pos/Incomplete Tests"
- WRITE ?28,$JUSTIFY(A,2),?32,R,?38,I,?53,Y
- QUIT
- +1 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"BLOOD BANK",?21,"SHIPPING INVOICE#: ",LRB,!?21,"To: ",LR
- FOR X=0:0
- SET X=$ORDER(LR(X))
- if 'X
- QUIT
- if LR(X)]""
- WRITE !?25,LR(X)
- +2 QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !?28,"ABO",?32,"Rh",?38,"UNIT ID",?53,"Expiration date",!,LR("%")
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- WRITE !!,"Component: ",C(1)
- if C(20)]""
- WRITE " (",C(20),")"
- WRITE !
- QUIT
- H3 DO H
- if LR("Q")
- QUIT
- WRITE !,LR("%"),!!!
- QUIT
- +1 ;
- CK IF $LENGTH(X)>30!(X'?.ANP)!(X["?")
- WRITE !,$CHAR(7),"Entry must be less than 31 characters with no control characters."
- KILL X
- +1 QUIT
- E if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- KILL ^TMP($JOB)
- WRITE !,LR("%")
- SET X=^LAB(65.9,LRI,0)
- SET DIWL=$PIECE(X,U,5)
- SET DIWR=IOM-$PIECE(X,U,6)
- SET DIWF="W"
- +1 SET LRA=0
- FOR LRZ=0:1
- SET LRA=$ORDER(^LAB(65.9,LRI,2,LRA))
- if 'LRA!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H3
- if LR("Q")
- QUIT
- SET X=^LAB(65.9,LRI,2,LRA,0)
- DO ^DIWP
- +2 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- QUIT
- END DO V^LRU
- QUIT