- LRBLQPR ; IHS/DIR/FJE - PRINT UNITS/COMPONENTS 2/18/93 09:48 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
- P W ! K DIC D ^LRDPA K DIC,DIE,DR W ! G:LRDFN=-1 END
- W !,"Is this the patient " S %=1 D YN^LRU G:%'=1 P
- S ZTRTN="QUE^LRBLQPR" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D S^LRU I $A(IOST)=80 S A(1)=0 D L^LRU,H
- ;I $A(IOST)'=80 W @IOF,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH
- I $A(IOST)'=80 W @IOF,LRP," ",HRCN,?37,$J(LRPABO,2),?40,LRPRH ;IHS/ANMC/CLS 11/1/95
- D S S A(1)=(IOSL-3) F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A D N
- I B=1 W !,"No UNITS assigned/xmatched",!
- G:A(2)?1P END W ! D S F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A S X=^(A,0) W:'B !,"Component Requests",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By" D L
- I 'B W "No component requests",!
- D END^LRUTL,END Q
- ;
- N W:B=1 !?6,"Unit assigned/xmatched:",?46,"Exp date",?64,"Loc"
- I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
- D:$Y>A(1) R Q:A(2)?1P S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
- S M=^LAB(66,$P(X,"^",4),0) W !,$J(B,2),")",?6,$P(X,"^"),?17,$E($P(M,"^"),1,19),?38,$P(X,"^",7)_" "_$P(X,"^",8),?45 S Y=$P(X,"^",6) D D^LRU S:L<0 L="Blood bank" W Y,?64,$E(L,1,16)
- S C=$O(^LRD(65,A,2,LRDFN,1,0)) I C F E=0:0 S E=$O(^LRD(65,A,2,LRDFN,1,C,3,E)) Q:'E D:$Y>A(1) R Q:A(2)?1P W !?2,^(E,0)
- Q
- ;
- L D:$Y>A(1) R Q:A(2)?1P
- W !,$E($P(^LAB(66,+X,0),"^"),1,27),?27,$J($P(X,"^",4),3),?33 S Y=$P(X,"^",3) D M W Y,?47 S Y=$P(X,"^",5) D M W Y,?59,$P(X,"^",9),?77,$S($P(X,"^",8)="":"",$D(^VA(200,$P(X,"^",8),0)):$P(^(0),"^",2),1:$P(X,"^",8)) Q
- M S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y'[".":"",1:" "_$E(Y,9,12)) Q
- D END^LRUTL,END Q
- ;
- R G:$A(IOST)=80 H S A(1)=A(1)+21 R !,"^ TO STOP: ",A(2):DTIME I A(2)?1P S A=0 Q
- S A(1)=A(1)+21 W $C(13),$J("",15),$C(13) Q
- S S (A,A(2))=0 Q
- ;
- H D F^LRU W !,"LABORATORY SERVICE",!,LR("%")
- ;W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH S A(1)=A(1)+(IOSL-4) Q
- W !,LRP," ",HRCN,?37,$J(LRPABO,2),?40,LRPRH S A(1)=A(1)+(IOSL-4) Q ;IHS/ANMC/CLS 11/1/95
- ;
- END D V^LRU Q
- LRBLQPR ; IHS/DIR/FJE - PRINT UNITS/COMPONENTS 2/18/93 09:48 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- P WRITE !
- KILL DIC
- DO ^LRDPA
- KILL DIC,DIE,DR
- WRITE !
- IF LRDFN=-1
- GOTO END
- +1 WRITE !,"Is this the patient "
- SET %=1
- DO YN^LRU
- IF %'=1
- GOTO P
- +2 SET ZTRTN="QUE^LRBLQPR"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO S^LRU
- IF $ASCII(IOST)=80
- SET A(1)=0
- DO L^LRU
- DO H
- +1 ;I $A(IOST)'=80 W @IOF,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH
- +2 ;IHS/ANMC/CLS 11/1/95
- IF $ASCII(IOST)'=80
- WRITE @IOF,LRP," ",HRCN,?37,$JUSTIFY(LRPABO,2),?40,LRPRH
- +3 DO S
- SET A(1)=(IOSL-3)
- FOR B=1:1
- SET A=$ORDER(^LRD(65,"AP",LRDFN,A))
- IF 'A
- QUIT
- DO N
- +4 IF B=1
- WRITE !,"No UNITS assigned/xmatched",!
- +5 IF A(2)?1P
- GOTO END
- WRITE !
- DO S
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,1.8,A))
- IF 'A
- QUIT
- SET X=^(A,0)
- IF 'B
- WRITE !,"Component Requests",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By"
- DO L
- +6 IF 'B
- WRITE "No component requests",!
- +7 DO END^LRUTL
- DO END
- QUIT
- +8 ;
- N IF B=1
- WRITE !?6,"Unit assigned/xmatched:",?46,"Exp date",?64,"Loc"
- +1 IF '$DATA(^LRD(65,A,0))
- KILL ^LRD(65,"AP",LRDFN,A)
- QUIT
- +2 IF $Y>A(1)
- DO R
- IF A(2)?1P
- QUIT
- SET X=^LRD(65,A,0)
- SET L=$ORDER(^(3,0))
- IF 'L
- SET L="Blood Bank"
- IF L
- SET L=$PIECE(^(L,0),"^",4)
- +3 SET M=^LAB(66,$PIECE(X,"^",4),0)
- WRITE !,$JUSTIFY(B,2),")",?6,$PIECE(X,"^"),?17,$EXTRACT($PIECE(M,"^"),1,19),?38,$PIECE(X,"^",7)_" "_$PIECE(X,"^",8),?45
- SET Y=$PIECE(X,"^",6)
- DO D^LRU
- IF L<0
- SET L="Blood bank"
- WRITE Y,?64,$EXTRACT(L,1,16)
- +4 SET C=$ORDER(^LRD(65,A,2,LRDFN,1,0))
- IF C
- FOR E=0:0
- SET E=$ORDER(^LRD(65,A,2,LRDFN,1,C,3,E))
- IF 'E
- QUIT
- IF $Y>A(1)
- DO R
- IF A(2)?1P
- QUIT
- WRITE !?2,^(E,0)
- +5 QUIT
- +6 ;
- L IF $Y>A(1)
- DO R
- IF A(2)?1P
- QUIT
- +1 WRITE !,$EXTRACT($PIECE(^LAB(66,+X,0),"^"),1,27),?27,$JUSTIFY($PIECE(X,"^",4),3),?33
- SET Y=$PIECE(X,"^",3)
- DO M
- WRITE Y,?47
- SET Y=$PIECE(X,"^",5)
- DO M
- WRITE Y,?59,$PIECE(X,"^",9),?77,$SELECT($PIECE(X,"^",8)="":"",$DATA(^VA(200,$PIECE(X,"^",8),0)):$PIECE(^(0),"^",2),1:$PIECE(X,"^",8))
- QUIT
- M SET Y=Y_"000"
- SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_$SELECT(Y'[".":"",1:" "_$EXTRACT(Y,9,12))
- QUIT
- +1 DO END^LRUTL
- DO END
- QUIT
- +2 ;
- R IF $ASCII(IOST)=80
- GOTO H
- SET A(1)=A(1)+21
- READ !,"^ TO STOP: ",A(2):DTIME
- IF A(2)?1P
- SET A=0
- QUIT
- +1 SET A(1)=A(1)+21
- WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
- QUIT
- S SET (A,A(2))=0
- QUIT
- +1 ;
- H DO F^LRU
- WRITE !,"LABORATORY SERVICE",!,LR("%")
- +1 ;W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH S A(1)=A(1)+(IOSL-4) Q
- +2 ;IHS/ANMC/CLS 11/1/95
- WRITE !,LRP," ",HRCN,?37,$JUSTIFY(LRPABO,2),?40,LRPRH
- SET A(1)=A(1)+(IOSL-4)
- QUIT
- +3 ;
- END DO V^LRU
- QUIT
