LRBLJLA ;AVAMC/REG/CYM - CROSSMATCH LABELS ;6/17/96 14:21 ;
;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D END,CK^LRBLPUS G:Y=-1 END S:'$D(^LRO(69.2,LRAA,9,0)) ^(0)="^69.25A^^"
W !?30,"PRINT XMATCH LABELS" S X=$P(^LRO(69.2,LRAA,9,0),"^",4) W:X !?25,"(There ",$S(X>1:"are",1:"is")," ",X," label",$S(X>1:"s",1:"")," to print)"
W !?3,"Add labels for emergency transfusion " S %=2 D YN^LRU I %=1 D E
W !! I '$O(^LRO(69.2,LRAA,9,0)) W $C(7),!!,"THERE ARE NO LABELS TO PRINT !",!,"DO WANT TO ADD SOME OF YOUR OWN" S %=2 D YN^LRU G:%'=1 END D C G ED
W !,"Do you want to delete the list of labels " S %=2 D YN^LRU I %=1 W $C(7),!,"Are you sure " S %=2 D YN^LRU I %=1 W " OK, List DELETED." K ^LRO(69.2,LRAA,9) D END Q
ED W !,"Edit LABELS " S %=2 D YN^LRU G:%<1 END D:%=1 C
W !!,"Save list for repeat printing " S %=2 D YN^LRU G:%<1 END S:%=1 LRQ=1
W !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
S LR(1)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,7),1:"")
I W !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$S(LR(1):"// ",1:"") R X:DTIME G:'$T!(X[U) END S X=$S(X="":LR(1),$L(X)>2:X=1,1:X)
ASK W ! X $P(^DD(69.2,.07,0),"^",5,99) I '$D(X) W:$D(^DD(69.2,.07,3)) !,$C(7),^(3) X:$D(^(4)) ^(4) G I
I X["?" S X="ZZZ" G ASK
S LR(1)=X
S ZTRTN="QUE^LRBLJLA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO
F A=0:0 S A=$O(^LRO(69.2,LRAA,9,A)) Q:'A S X=^(A,0) F B=1:1:LR(1) W $P(X,"^",B),!
OUT K:'$D(LRQ) ^LRO(69.2,LRAA,9) K %ZIS S (LR("FORM"),LR("LINE"))=1 D END^LRUTL,END Q
;
C W ! S DIC="^LRO(69.2,LRAA,9,",DLAYGO=69,DIC(0)="AEQLM",DIC("A")="Select Unit ID: " D ^DIC K DIC,DLAYGO Q:X=""!(X[U) S DA=+Y
S DIE="^LRO(69.2,LRAA,9,",DR=".01:.05",DA=+Y D ^DIE K DIC,DIE,DR,DA,D G C
;
E S:'$D(^LRO(69.2,LRAA,9,0)) ^(0)="^69.25A^^"
A K DIC D ^LRDPA Q:LRDFN=-1 S X=^LR(LRDFN,0),Y=$P(X,"^",3),LRABO=$P(X,"^",5),LRRH=$P(X,"^",6),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),Z=$S($D(@(X_Y_",.35)")):+^(.35),1:0),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU
I Z W $C(7),! G A
B R !!,"Enter number of crossmatch labels wanted: ",LRB:DTIME Q:LRB=""!(LRB[U) I LRB<1!(LRB>99) W $C(7),!,"Enter a number from 1 to 99." G B
S %DT="T",X="N" D ^%DT,D^LRU
L +^LRO(69.2,LRAA,9):5 I '$T W $C(7),!!,"I can't make those extra labels now.",!!,"Someone else started this first",!!,"Try again later if you still need extras",!! Q
S X=^LRO(69.2,LRAA,9,0),LRC=$P(X,"^",3)+1,Z=$P(X,"^",3)+LRB,^(0)=$P(X,"^",1,2)_"^"_Z_"^"_Z
F A=LRC:1:Z S ^LRO(69.2,LRAA,9,A,0)=Y_"^"_LRP_" "_SSN_"^"_"Patient ABO/Rh: "_LRABO_" "_LRRH_"^"_"Unit ABO/Rh: Unit#:"_"^"_"Crossmatch: Tech :"
L -^LRO(69.2,LRAA,9) Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJLA 2799 printed Apr 09, 2024@21:25:14 Page 2
LRBLJLA ;AVAMC/REG/CYM - CROSSMATCH LABELS ;6/17/96 14:21 ;
+1 ;;5.2;LAB SERVICE;**72,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
DO CK^LRBLPUS
if Y=-1
GOTO END
if '$DATA(^LRO(69.2,LRAA,9,0))
SET ^(0)="^69.25A^^"
+4 WRITE !?30,"PRINT XMATCH LABELS"
SET X=$PIECE(^LRO(69.2,LRAA,9,0),"^",4)
if X
WRITE !?25,"(There ",$SELECT(X>1:"are",1:"is")," ",X," label",$SELECT(X>1:"s",1:"")," to print)"
+5 WRITE !?3,"Add labels for emergency transfusion "
SET %=2
DO YN^LRU
IF %=1
DO E
+6 WRITE !!
IF '$ORDER(^LRO(69.2,LRAA,9,0))
WRITE $CHAR(7),!!,"THERE ARE NO LABELS TO PRINT !",!,"DO WANT TO ADD SOME OF YOUR OWN"
SET %=2
DO YN^LRU
if %'=1
GOTO END
DO C
GOTO ED
+7 WRITE !,"Do you want to delete the list of labels "
SET %=2
DO YN^LRU
IF %=1
WRITE $CHAR(7),!,"Are you sure "
SET %=2
DO YN^LRU
IF %=1
WRITE " OK, List DELETED."
KILL ^LRO(69.2,LRAA,9)
DO END
QUIT
ED WRITE !,"Edit LABELS "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=1
DO C
+1 WRITE !!,"Save list for repeat printing "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=1
SET LRQ=1
+2 WRITE !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
+3 SET LR(1)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,7),1:"")
I WRITE !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$SELECT(LR(1):"// ",1:"")
READ X:DTIME
if '$TEST!(X[U)
GOTO END
SET X=$SELECT(X="":LR(1),$LENGTH(X)>2:X=1,1:X)
ASK WRITE !
XECUTE $PIECE(^DD(69.2,.07,0),"^",5,99)
IF '$DATA(X)
if $DATA(^DD(69.2,.07,3))
WRITE !,$CHAR(7),^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO I
+1 IF X["?"
SET X="ZZZ"
GOTO ASK
+2 SET LR(1)=X
+3 SET ZTRTN="QUE^LRBLJLA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
+1 FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,9,A))
if 'A
QUIT
SET X=^(A,0)
FOR B=1:1:LR(1)
WRITE $PIECE(X,"^",B),!
OUT if '$DATA(LRQ)
KILL ^LRO(69.2,LRAA,9)
KILL %ZIS
SET (LR("FORM"),LR("LINE"))=1
DO END^LRUTL
DO END
QUIT
+1 ;
C WRITE !
SET DIC="^LRO(69.2,LRAA,9,"
SET DLAYGO=69
SET DIC(0)="AEQLM"
SET DIC("A")="Select Unit ID: "
DO ^DIC
KILL DIC,DLAYGO
if X=""!(X[U)
QUIT
SET DA=+Y
+1 SET DIE="^LRO(69.2,LRAA,9,"
SET DR=".01:.05"
SET DA=+Y
DO ^DIE
KILL DIC,DIE,DR,DA,D
GOTO C
+2 ;
E if '$DATA(^LRO(69.2,LRAA,9,0))
SET ^(0)="^69.25A^^"
A KILL DIC
DO ^LRDPA
if LRDFN=-1
QUIT
SET X=^LR(LRDFN,0)
SET Y=$PIECE(X,"^",3)
SET LRABO=$PIECE(X,"^",5)
SET LRRH=$PIECE(X,"^",6)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET Z=$SELECT($DATA(@(X_Y_",.35)")):+^(.35),1:0)
SET X=@(X_Y_",0)")
SET LRP=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
DO SSN^LRU
+1 IF Z
WRITE $CHAR(7),!
GOTO A
B READ !!,"Enter number of crossmatch labels wanted: ",LRB:DTIME
if LRB=""!(LRB[U)
QUIT
IF LRB<1!(LRB>99)
WRITE $CHAR(7),!,"Enter a number from 1 to 99."
GOTO B
+1 SET %DT="T"
SET X="N"
DO ^%DT
DO D^LRU
+2 LOCK +^LRO(69.2,LRAA,9):5
IF '$TEST
WRITE $CHAR(7),!!,"I can't make those extra labels now.",!!,"Someone else started this first",!!,"Try again later if you still need extras",!!
QUIT
+3 SET X=^LRO(69.2,LRAA,9,0)
SET LRC=$PIECE(X,"^",3)+1
SET Z=$PIECE(X,"^",3)+LRB
SET ^(0)=$PIECE(X,"^",1,2)_"^"_Z_"^"_Z
+4 FOR A=LRC:1:Z
SET ^LRO(69.2,LRAA,9,A,0)=Y_"^"_LRP_" "_SSN_"^"_"Patient ABO/Rh: "_LRABO_" "_LRRH_"^"_"Unit ABO/Rh: Unit#:"_"^"_"Crossmatch: Tech :"
+5 LOCK -^LRO(69.2,LRAA,9)
QUIT
+6 ;
END DO V^LRU
QUIT
