- LRBLJLA ; IHS/DIR/AAB - CROSSMATCH LABELS 6/17/96 14:21 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- 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
- K DIC D ^LRDPA Q:LRDFN=-1 S X=^LR(LRDFN,0),(DFN,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 ;IHS/ANMC/CLS
- 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 :"
- F A=LRC:1:Z S ^LRO(69.2,LRAA,9,A,0)=Y_"^"_LRP_" "_HRCN_"^"_"Patient ABO/Rh: "_LRABO_" "_LRRH_"^"_"Unit ABO/Rh: Unit#:"_"^"_"Crossmatch: Tech :" ;IHS/ANMC/CLS 11/1/95
- L -^LRO(69.2,LRAA,9) Q
- ;
- END D V^LRU Q
- LRBLJLA ; IHS/DIR/AAB - CROSSMATCH LABELS 6/17/96 14:21 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 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 ;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
- +1 ;IHS/ANMC/CLS
- KILL DIC
- DO ^LRDPA
- IF LRDFN=-1
- QUIT
- SET X=^LR(LRDFN,0)
- SET (DFN,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
- +2 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 ;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 :"
- +5 ;IHS/ANMC/CLS 11/1/95
- FOR A=LRC:1:Z
- SET ^LRO(69.2,LRAA,9,A,0)=Y_"^"_LRP_" "_HRCN_"^"_"Patient ABO/Rh: "_LRABO_" "_LRRH_"^"_"Unit ABO/Rh: Unit#:"_"^"_"Crossmatch: Tech :"
- +6 LOCK -^LRO(69.2,LRAA,9)
- QUIT
- +7 ;
- END DO V^LRU
- QUIT
