- LRBLDA ; IHS/DIR/FJE - BLOOD DONOR LIST 2/18/93 08:43 ;
- ;;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 S (LRF,LRY)=""
- W @IOF,!?24,"PRINT BLOOD DONOR LIST/LABELS/LETTERS"
- L W !!?14,"1. DONOR LIST",!?14,"2. DONOR LABELS",!?14,"3. DONOR PRE -VISIT LETTERS",!?14,"4. DONOR POST-VISIT LETTERS",!,"Select (1-4): " R X:DTIME G:X=""!(X[U) END
- I X'=+X!(X<1)!(X>4) W $C(7),!,"Enter a number from 1 to 4" G L
- S LRS=X G:X=4 ^LRBLDAA I X=3 W !!,"Letter for a single donor " S %=2 D YN^LRU G:%=1 O W !!
- S LR(2)="",LR=0,%DT="AEX",%DT(0)="-N",%DT("A")="Date since last donation: " D ^%DT K %DT G:Y<1 END S LRSDT=9999998-Y D D^LRU S LRSTR=Y
- W !!,"DONORS FROM A SPECIFIC GROUP AFFILIATION " S %=2 D YN^LRU G:%<1 END
- I %=1 S DIC=65.4,DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,2)[""G""",DIC("A")="Select DONOR GROUP AFFILIATION: " D ^DIC K DIC G:X=""!(X[U) END S LR=+Y,LR(2)=$P(Y,U,2),LRY=$P(Y(0),U,3)
- S R !!,"Start with BLOOD DONOR NAME: FIRST// ",X:DTIME G:X[U!'$T END I X="" S LRP(1)=0,LRP(2)="z" G A
- I X["?"!(X'?1U.E)!($L(X)>30) D H^LRU G S
- S LRP(1)=X I $L(X)>1 S X(1)=$A(X,$L(X))-1,X(1)=$C(X(1)),LRP(1)=$E(X,1,$L(X)-1)_X(1)
- F R !,"Go to BLOOD DONOR NAME: LAST// ",X:DTIME G:X[U!'$T END I X="" S LRP(2)="z" G A
- I X["?"!(X'?1U.E)!($L(X)>30) D H1^LRU G F
- S LRP(2)=X
- A S (LRABO,LRRH)="" W !!,"Specify ABO Group and/or Rh Type " S %=2 D YN^LRU G:%<1 END I %=1 D EN^LRBLDA1 G:'$D(Y) END
- G B:LRS=2,C:LRS=3 S ZTRTN="QUE^LRBLDA" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D L^LRU,S^LRU,H S LR("F")=1
- S LRP=LRP(1) F LRA=0:1 S LRP=$O(^LRE("B",LRP)) Q:LRP=""!(LRP]LRP(2))!(LR("Q")) F LRI=0:0 S LRI=$O(^LRE("B",LRP,LRI)) Q:LRI<1!(LR("Q")) S LRW=$O(^LRE(LRI,5,0)) I LRW>LRSDT S LRW=^(LRW,0) D W
- D END^LRUTL,V^LRU Q
- ;
- W S X=^LRE(LRI,0) Q:$P(X,"^",10) Q:LRABO]""&($P(X,"^",5)'=LRABO) Q:LRRH]""&($P(X,"^",6)'=LRRH)
- D:$Y>(IOSL-11) H Q:LR("Q") S LRW(7)=$P(LRW,"^",7) I LR,LRW(7)'=LR,'$D(^LRE(LRI,2,LR)) Q
- W !,LRP S Y=+LRW D D^LRU W ?31,$E(Y,1,12) I LRW(7),$D(^LAB(65.4,LRW(7),0)) W ?45,$E($P(^(0),"^",3),1,30)
- I $D(^LRE(LRI,1)) S X=^(1),Y=$P(X,"^",7),O=$P(X,"^",8) W:IOM>118 ?76,Y,?93,O W:IOM<119&(Y]""!(O]"")) !?5,Y,?25,O
- F B=0:0 S B=$O(^LRE(LRI,2,B)) Q:'B I B'=LRW(7),$D(^LAB(65.4,B,0)) W !?45,$E($P(^(0),"^",3),1,30)
- Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,LRAA(1),!,"NO " W:LR(2)]"" LR(2)," " W "DONATIONS SINCE ",LRSTR
- W !,"Donor",?31,"Last donation",?55,"Group" W:IOM>118 ?76,"Home phone",?93,"Work phone" W:IOM<119 !?5,"Home phone",?25,"Work phone" W !,LR("%") Q
- ;
- B 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),"^",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 Q:'$T!(X[U) S X=$S(X="":LR(1),$L(X)>2:X=1,1:X)
- 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
- S LR(1)=X
- S ZTRTN="^LRBLDA1" D BEG^LRUTL G:POP!($D(ZTSK)) END
- W ! G ^LRBLDA1
- ;
- LTR W ! S DIC("S")="I '$P(^(0),U,2)",DIC="^LAB(65.9,",DIC(0)="AEQMZ",DIC("A")="Select BLOOD DONOR LETTER: " D ^DIC K DIC S LRL=Y I $P(Y,U,2)="RBC ANTIGEN ABSENT, DONOR" D EN1^LRBLDA1 S Y=1 S:'$D(LRJ) Y=-1
- Q
- C D LTR G:Y<1 END S ZTRTN="^LRBLDAL" D BEG^LRUTL G:POP!($D(ZTSK)) END
- W ! G ^LRBLDAL
- ;
- O D LTR G:Y<1 END
- ASK W ! S DIC="^LRE(",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<1 END
- S LRP=$P(Y,U,2),LRI=+Y I $P(Y(0),U,10) W $C(7),!,"Donor permanently deferred. Are you sure " D YN^LRU G:%'=1 ASK
- S ZTRTN="EN^LRBLDAL" D BEG^LRUTL G:POP!($D(ZTSK)) END W ! G EN^LRBLDAL
- ;
- END K ^TMP("LRBLY") D V^LRU Q
- LRBLDA ; IHS/DIR/FJE - BLOOD DONOR LIST 2/18/93 08:43 ;
- +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
- SET (LRF,LRY)=""
- +5 WRITE @IOF,!?24,"PRINT BLOOD DONOR LIST/LABELS/LETTERS"
- L WRITE !!?14,"1. DONOR LIST",!?14,"2. DONOR LABELS",!?14,"3. DONOR PRE -VISIT LETTERS",!?14,"4. DONOR POST-VISIT LETTERS",!,"Select (1-4): "
- READ X:DTIME
- IF X=""!(X[U)
- GOTO END
- +1 IF X'=+X!(X<1)!(X>4)
- WRITE $CHAR(7),!,"Enter a number from 1 to 4"
- GOTO L
- +2 SET LRS=X
- IF X=4
- GOTO ^LRBLDAA
- IF X=3
- WRITE !!,"Letter for a single donor "
- SET %=2
- DO YN^LRU
- IF %=1
- GOTO O
- WRITE !!
- +3 SET LR(2)=""
- SET LR=0
- SET %DT="AEX"
- SET %DT(0)="-N"
- SET %DT("A")="Date since last donation: "
- DO ^%DT
- KILL %DT
- IF Y<1
- GOTO END
- SET LRSDT=9999998-Y
- DO D^LRU
- SET LRSTR=Y
- +4 WRITE !!,"DONORS FROM A SPECIFIC GROUP AFFILIATION "
- SET %=2
- DO YN^LRU
- IF %<1
- GOTO END
- +5 IF %=1
- SET DIC=65.4
- SET DIC(0)="AEQMZ"
- SET DIC("S")="I $P(^(0),U,2)[""G"""
- SET DIC("A")="Select DONOR GROUP AFFILIATION: "
- DO ^DIC
- KILL DIC
- IF X=""!(X[U)
- GOTO END
- SET LR=+Y
- SET LR(2)=$PIECE(Y,U,2)
- SET LRY=$PIECE(Y(0),U,3)
- S READ !!,"Start with BLOOD DONOR NAME: FIRST// ",X:DTIME
- IF X[U!'$TEST
- GOTO END
- IF X=""
- SET LRP(1)=0
- SET LRP(2)="z"
- GOTO A
- +1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
- DO H^LRU
- GOTO S
- +2 SET LRP(1)=X
- IF $LENGTH(X)>1
- SET X(1)=$ASCII(X,$LENGTH(X))-1
- SET X(1)=$CHAR(X(1))
- SET LRP(1)=$EXTRACT(X,1,$LENGTH(X)-1)_X(1)
- F READ !,"Go to BLOOD DONOR NAME: LAST// ",X:DTIME
- IF X[U!'$TEST
- GOTO END
- IF X=""
- SET LRP(2)="z"
- GOTO A
- +1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
- DO H1^LRU
- GOTO F
- +2 SET LRP(2)=X
- A SET (LRABO,LRRH)=""
- WRITE !!,"Specify ABO Group and/or Rh Type "
- SET %=2
- DO YN^LRU
- IF %<1
- GOTO END
- IF %=1
- DO EN^LRBLDA1
- IF '$DATA(Y)
- GOTO END
- +1 IF LRS=2
- GOTO B
- IF LRS=3
- GOTO C
- SET ZTRTN="QUE^LRBLDA"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- +1 SET LRP=LRP(1)
- FOR LRA=0:1
- SET LRP=$ORDER(^LRE("B",LRP))
- IF LRP=""!(LRP]LRP(2))!(LR("Q"))
- QUIT
- FOR LRI=0:0
- SET LRI=$ORDER(^LRE("B",LRP,LRI))
- IF LRI<1!(LR("Q"))
- QUIT
- SET LRW=$ORDER(^LRE(LRI,5,0))
- IF LRW>LRSDT
- SET LRW=^(LRW,0)
- DO W
- +2 DO END^LRUTL
- DO V^LRU
- QUIT
- +3 ;
- W SET X=^LRE(LRI,0)
- IF $PIECE(X,"^",10)
- QUIT
- IF LRABO]""&($PIECE(X,"^",5)'=LRABO)
- QUIT
- IF LRRH]""&($PIECE(X,"^",6)'=LRRH)
- QUIT
- +1 IF $Y>(IOSL-11)
- DO H
- IF LR("Q")
- QUIT
- SET LRW(7)=$PIECE(LRW,"^",7)
- IF LR
- IF LRW(7)'=LR
- IF '$DATA(^LRE(LRI,2,LR))
- QUIT
- +2 WRITE !,LRP
- SET Y=+LRW
- DO D^LRU
- WRITE ?31,$EXTRACT(Y,1,12)
- IF LRW(7)
- IF $DATA(^LAB(65.4,LRW(7),0))
- WRITE ?45,$EXTRACT($PIECE(^(0),"^",3),1,30)
- +3 IF $DATA(^LRE(LRI,1))
- SET X=^(1)
- SET Y=$PIECE(X,"^",7)
- SET O=$PIECE(X,"^",8)
- IF IOM>118
- WRITE ?76,Y,?93,O
- IF IOM<119&(Y]""!(O]""))
- WRITE !?5,Y,?25,O
- +4 FOR B=0:0
- SET B=$ORDER(^LRE(LRI,2,B))
- IF 'B
- QUIT
- IF B'=LRW(7)
- IF $DATA(^LAB(65.4,B,0))
- WRITE !?45,$EXTRACT($PIECE(^(0),"^",3),1,30)
- +5 QUIT
- +6 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,LRAA(1),!,"NO "
- IF LR(2)]""
- WRITE LR(2)," "
- WRITE "DONATIONS SINCE ",LRSTR
- +2 WRITE !,"Donor",?31,"Last donation",?55,"Group"
- IF IOM>118
- WRITE ?76,"Home phone",?93,"Work phone"
- IF IOM<119
- WRITE !?5,"Home phone",?25,"Work phone"
- WRITE !,LR("%")
- QUIT
- +3 ;
- B WRITE !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
- SET LR(1)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),"^",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)
- QUIT
- SET X=$SELECT(X="":LR(1),$LENGTH(X)>2:X=1,1:X)
- +1 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
- +2 SET LR(1)=X
- +3 SET ZTRTN="^LRBLDA1"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- +4 WRITE !
- GOTO ^LRBLDA1
- +5 ;
- LTR WRITE !
- SET DIC("S")="I '$P(^(0),U,2)"
- SET DIC="^LAB(65.9,"
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select BLOOD DONOR LETTER: "
- DO ^DIC
- KILL DIC
- SET LRL=Y
- IF $PIECE(Y,U,2)="RBC ANTIGEN ABSENT, DONOR"
- DO EN1^LRBLDA1
- SET Y=1
- IF '$DATA(LRJ)
- SET Y=-1
- +1 QUIT
- C DO LTR
- IF Y<1
- GOTO END
- SET ZTRTN="^LRBLDAL"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- +1 WRITE !
- GOTO ^LRBLDAL
- +2 ;
- O DO LTR
- IF Y<1
- GOTO END
- ASK WRITE !
- SET DIC="^LRE("
- SET DIC(0)="AEQMZ"
- DO ^DIC
- KILL DIC
- IF Y<1
- GOTO END
- +1 SET LRP=$PIECE(Y,U,2)
- SET LRI=+Y
- IF $PIECE(Y(0),U,10)
- WRITE $CHAR(7),!,"Donor permanently deferred. Are you sure "
- DO YN^LRU
- IF %'=1
- GOTO ASK
- +2 SET ZTRTN="EN^LRBLDAL"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- WRITE !
- GOTO EN^LRBLDAL
- +3 ;
- END KILL ^TMP("LRBLY")
- DO V^LRU
- QUIT
