- LRBLDAL ; IHS/DIR/FJE - BLOOD DONOR LETTERS 7/18/91 08:52 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- U IO S ^TMP("LRBLY",65.5,2)=LRY,^TMP("LRBLY",65.5,6.2)=LRF I '$D(^LAB(65.9,+LRL,0)) W !!,"Blood bank letter ",$P(LRL,U,2)," has been deleted." G END
- D SET
- S LRP=LRP(1) F LRA=0:1 S LRP=$O(^LRE("B",LRP)) Q:LRP=""!(LRP]LRP(2)) F LRI=0:0 S LRI=$O(^LRE("B",LRP,LRI)) Q:LRI<1 S LRW=$O(^LRE(LRI,5,0)) I LRW>LRSDT S LRW=^(LRW,0) D W
- G END
- W S X=^LRE(LRI,0) Q:$P(X,"^",10) Q:LRABO]""&($P(X,"^",5)'=LRABO) Q:LRRH]""&($P(X,"^",6)'=LRRH)
- S LRW(7)=$P(LRW,"^",7) I LR,LRW(7)'=LR,'$D(^LRE(LRI,2,LR)) Q
- SGL I $D(LRJ) S A=0 D AA Q:A
- EN1 ;from LRBLDAA
- S X=^LRE(LRI,0),^TMP("LRBLY",65.5,.05)=$P(X,"^",5),^(.07)=$P(X,"^",7),^(.08)=$P(X,"^",8),X=$P(X,"^",6),^(.06)=$S(X="POS":"POSITIVE",X="NEG":"NEGATIVE",1:"")
- S X1=+LRW,X2=$S(LRY="W":57,LRY="P":3,1:"") D C^%DTC S Y=X D D^LRU S ^TMP("LRBLY",65.5,"NEXT")=Y
- S LRD=$S($D(^LRE(LRI,1)):^(1),1:""),LRQ=1,Y=+LRW D:Y M
- S ^TMP("LRBLY",65.5,5)=Y,X=$P(LRW,"^",6),X=$S('X:"",$D(^LAB(65.4,X,0)):$P(^(0),U,3),1:""),^TMP("LRBLY",65.54,.02)=X,X=$P(LRW,"^",7),X=$S('X:"",$D(^LAB(65.4,X,0)):$P(^(0),U,3),1:""),^TMP("LRBLY",65.54,.03)=X
- W @IOF F X=1:1:LRT W !
- W ?LRS(1),LRT(1),!!
- F X=2:1:6 W:LRS(X)]"" !?LRS(1),LRS(X)
- W !!?DIWL-1,$P(LRP,",",2)," ",$P(LRP,",")
- F X=1:1:3 I $P(LRD,"^",X)]"" W !?DIWL-1,$P(LRD,"^",X)
- W !?DIWL-1,$P(LRD,"^",4) S X=$P(LRD,"^",5) I X,$D(^DIC(5,X,0)) W ", ",$P(^(0),"^",2)," ",$P(LRD,"^",6)
- S Y=$P($P(LRP,",",2)," "),X=$E(Y,2,99) D C^LRUA S Y=$E(Y)_X
- W !!?DIWL-1,"Dear ",Y,","
- W !! K ^TMP($J) S LRC=0 F LRZ=0:1 S LRC=$O(^LAB(65.9,LRL,2,LRC)) Q:'LRC D:$Y>(IOSL-LRB) HDR S X=^LAB(65.9,LRL,2,LRC,0) D:+$P(X,"[",2) ^LRBLY D:X["|TOP|" TOP D ^DIWP
- D:LRZ ^DIWW I LRV(3) D:$Y>(IOSL-LRB-LRV(3)) HDR F A=1:1:LRV(3) W !
- W:LRV(1)]"" !?LRS(1),LRV(1) W:LRV(2)]"" !?LRS(1),LRV(2) Q
- ;
- AA F B=0:0 S B=$O(LRJ(B)) Q:'B I '$D(^LRE(LRI,1.2,B)) S A=1 Q
- Q
- ;
- HDR S LRQ=LRQ+1 W @IOF,$P(LRP,",",2)," ",$P(LRP,","),?(IOM-10),"pg:",LRQ
- F X=1:1:LRT W !
- Q
- TOP S Z=$P(X,"|TOP|")_$P(X,"|TOP|",2) D HDR S X=Z Q
- Q
- SET S LRL=+LRL,X=^LAB(65.9,LRL,0),LRT=$P(X,U,3),LRB=$P(X,U,4),DIWL=$S($P(X,U,5):$P(X,U,5),1:5),DIWR=IOM-$P(X,U,6),DIWF=$S($P(X,U,7):"D",1:""),DIWF=DIWF_$S($P(X,U,8):"R",1:"")
- S X=$S($D(^LAB(65.9,LRL,3)):^(3),1:"") F A=1:1:3 S LRV(A)=$P(X,"^",A)
- S X=$S($D(^LAB(65.9,LRL,1)):^(1),1:"") F A=1:1:6 S LRS(A)=$P(X,"^",A)
- S X="T",%DT="" D ^%DT,D^LRU S LRT(1)=Y Q
- EN ;single donor
- U IO G:'$D(^LAB(65.9,+LRL,0)) END S:$D(LRF) ^TMP("LRBLY",65.5,6.2)=LRF S X=$O(^LRE(LRI,5,0)),LRW=$S('X:"",1:^(X,0)) D SET,SGL G END
- ;
- M S X=+$E(Y,4,5),X=$P("January^February^March^April^May^June^July^August^September^October^November^December","^",X),Y=X_" "_+$E(Y,6,7)_", "_(1700+$E(Y,1,3)) Q
- END K ^TMP("LRBLY") D END^LRUTL,V^LRU Q
- LRBLDAL ; IHS/DIR/FJE - BLOOD DONOR LETTERS 7/18/91 08:52 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 USE IO
- SET ^TMP("LRBLY",65.5,2)=LRY
- SET ^TMP("LRBLY",65.5,6.2)=LRF
- IF '$DATA(^LAB(65.9,+LRL,0))
- WRITE !!,"Blood bank letter ",$PIECE(LRL,U,2)," has been deleted."
- GOTO END
- +5 DO SET
- +6 SET LRP=LRP(1)
- FOR LRA=0:1
- SET LRP=$ORDER(^LRE("B",LRP))
- IF LRP=""!(LRP]LRP(2))
- QUIT
- FOR LRI=0:0
- SET LRI=$ORDER(^LRE("B",LRP,LRI))
- IF LRI<1
- QUIT
- SET LRW=$ORDER(^LRE(LRI,5,0))
- IF LRW>LRSDT
- SET LRW=^(LRW,0)
- DO W
- +7 GOTO END
- 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 SET LRW(7)=$PIECE(LRW,"^",7)
- IF LR
- IF LRW(7)'=LR
- IF '$DATA(^LRE(LRI,2,LR))
- QUIT
- SGL IF $DATA(LRJ)
- SET A=0
- DO AA
- IF A
- QUIT
- EN1 ;from LRBLDAA
- +1 SET X=^LRE(LRI,0)
- SET ^TMP("LRBLY",65.5,.05)=$PIECE(X,"^",5)
- SET ^(.07)=$PIECE(X,"^",7)
- SET ^(.08)=$PIECE(X,"^",8)
- SET X=$PIECE(X,"^",6)
- SET ^(.06)=$SELECT(X="POS":"POSITIVE",X="NEG":"NEGATIVE",1:"")
- +2 SET X1=+LRW
- SET X2=$SELECT(LRY="W":57,LRY="P":3,1:"")
- DO C^%DTC
- SET Y=X
- DO D^LRU
- SET ^TMP("LRBLY",65.5,"NEXT")=Y
- +3 SET LRD=$SELECT($DATA(^LRE(LRI,1)):^(1),1:"")
- SET LRQ=1
- SET Y=+LRW
- IF Y
- DO M
- +4 SET ^TMP("LRBLY",65.5,5)=Y
- SET X=$PIECE(LRW,"^",6)
- SET X=$SELECT('X:"",$DATA(^LAB(65.4,X,0)):$PIECE(^(0),U,3),1:"")
- SET ^TMP("LRBLY",65.54,.02)=X
- SET X=$PIECE(LRW,"^",7)
- SET X=$SELECT('X:"",$DATA(^LAB(65.4,X,0)):$PIECE(^(0),U,3),1:"")
- SET ^TMP("LRBLY",65.54,.03)=X
- +5 WRITE @IOF
- FOR X=1:1:LRT
- WRITE !
- +6 WRITE ?LRS(1),LRT(1),!!
- +7 FOR X=2:1:6
- IF LRS(X)]""
- WRITE !?LRS(1),LRS(X)
- +8 WRITE !!?DIWL-1,$PIECE(LRP,",",2)," ",$PIECE(LRP,",")
- +9 FOR X=1:1:3
- IF $PIECE(LRD,"^",X)]""
- WRITE !?DIWL-1,$PIECE(LRD,"^",X)
- +10 WRITE !?DIWL-1,$PIECE(LRD,"^",4)
- SET X=$PIECE(LRD,"^",5)
- IF X
- IF $DATA(^DIC(5,X,0))
- WRITE ", ",$PIECE(^(0),"^",2)," ",$PIECE(LRD,"^",6)
- +11 SET Y=$PIECE($PIECE(LRP,",",2)," ")
- SET X=$EXTRACT(Y,2,99)
- DO C^LRUA
- SET Y=$EXTRACT(Y)_X
- +12 WRITE !!?DIWL-1,"Dear ",Y,","
- +13 WRITE !!
- KILL ^TMP($JOB)
- SET LRC=0
- FOR LRZ=0:1
- SET LRC=$ORDER(^LAB(65.9,LRL,2,LRC))
- IF 'LRC
- QUIT
- IF $Y>(IOSL-LRB)
- DO HDR
- SET X=^LAB(65.9,LRL,2,LRC,0)
- IF +$PIECE(X,"[",2)
- DO ^LRBLY
- IF X["|TOP|"
- DO TOP
- DO ^DIWP
- +14 IF LRZ
- DO ^DIWW
- IF LRV(3)
- IF $Y>(IOSL-LRB-LRV(3))
- DO HDR
- FOR A=1:1:LRV(3)
- WRITE !
- +15 IF LRV(1)]""
- WRITE !?LRS(1),LRV(1)
- IF LRV(2)]""
- WRITE !?LRS(1),LRV(2)
- QUIT
- +16 ;
- AA FOR B=0:0
- SET B=$ORDER(LRJ(B))
- IF 'B
- QUIT
- IF '$DATA(^LRE(LRI,1.2,B))
- SET A=1
- QUIT
- +1 QUIT
- +2 ;
- HDR SET LRQ=LRQ+1
- WRITE @IOF,$PIECE(LRP,",",2)," ",$PIECE(LRP,","),?(IOM-10),"pg:",LRQ
- +1 FOR X=1:1:LRT
- WRITE !
- +2 QUIT
- TOP SET Z=$PIECE(X,"|TOP|")_$PIECE(X,"|TOP|",2)
- DO HDR
- SET X=Z
- QUIT
- +1 QUIT
- SET SET LRL=+LRL
- SET X=^LAB(65.9,LRL,0)
- SET LRT=$PIECE(X,U,3)
- SET LRB=$PIECE(X,U,4)
- SET DIWL=$SELECT($PIECE(X,U,5):$PIECE(X,U,5),1:5)
- SET DIWR=IOM-$PIECE(X,U,6)
- SET DIWF=$SELECT($PIECE(X,U,7):"D",1:"")
- SET DIWF=DIWF_$SELECT($PIECE(X,U,8):"R",1:"")
- +1 SET X=$SELECT($DATA(^LAB(65.9,LRL,3)):^(3),1:"")
- FOR A=1:1:3
- SET LRV(A)=$PIECE(X,"^",A)
- +2 SET X=$SELECT($DATA(^LAB(65.9,LRL,1)):^(1),1:"")
- FOR A=1:1:6
- SET LRS(A)=$PIECE(X,"^",A)
- +3 SET X="T"
- SET %DT=""
- DO ^%DT
- DO D^LRU
- SET LRT(1)=Y
- QUIT
- EN ;single donor
- +1 USE IO
- IF '$DATA(^LAB(65.9,+LRL,0))
- GOTO END
- IF $DATA(LRF)
- SET ^TMP("LRBLY",65.5,6.2)=LRF
- SET X=$ORDER(^LRE(LRI,5,0))
- SET LRW=$SELECT('X:"",1:^(X,0))
- DO SET
- DO SGL
- GOTO END
- +2 ;
- M SET X=+$EXTRACT(Y,4,5)
- SET X=$PIECE("January^February^March^April^May^June^July^August^September^October^November^December","^",X)
- SET Y=X_" "_+$EXTRACT(Y,6,7)_", "_(1700+$EXTRACT(Y,1,3))
- QUIT
- END KILL ^TMP("LRBLY")
- DO END^LRUTL
- DO V^LRU
- QUIT
