- LRIPOS2 ;AVAMC/REG - SET DD(65.091,.03 PART OF LRINIT POST INITS V 5.2;7/23/92 12:39
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ; If entries in MODIFIED/TO FROM FIELD then
- ; If disposition not modified or no disposition put a 1 in the
- ; ^DD(65.091,.03 field
- ; If unit is whole blood put a 2 in the 3rd piece of the zero subscript
- ; If divided unit put a 2 for each divided unit in 0;3
- ; Should be only ran during the post init process
- ; It does not do any harm to run this routine more than once.
- EN ;
- Q:'$D(DIFQ)
- Q:'$D(LRVR)!($G(LRVR)>5.1)
- W !,"Updating the Modified/To From Field in the Blood Bank Module",!
- F A=0:0 S A=$O(^LRD(65,A)) Q:'A I $O(^LRD(65,A,9,0)) S B=$S($D(^LRD(65,A,4)):$P(^(4),"^"),1:1) D A
- ADSOL Q:'$O(^LRE(0))
- W !!,"Changing ADSOL to CPD in the Donor file (#65.5) ^LRE( ",! ;for ^DD(65.54,4.11,0) entries
- S I=0 F S I=$O(^LRE(I)) Q:'I S LRI=0 F S LRI=$O(^LRE(I,5,LRI)) Q:'LRI S Y=$P($G(^(LRI,2)),"^",9) S:Y=4 $P(^(2),"^",9)=1
- W !,"Your file has been adjusted",!
- Q
- A W:'(A#100) "." I B'="MO" S P=1 D C Q
- I $S('$P($G(^LRD(65,A,0)),"^",4):1,'$D(^LAB(66,$P(^LRD(65,A,0),"^",4),0)):1,1:0) W !,"^LRD(65,",A,",entry corrupted or no entry in 4th piece of 0th subscript",!,"or no component entry in file 66 for unit",! Q
- I $P(^LAB(66,$P(^LRD(65,A,0),"^",4),0),"^",26)=1 S P=2 D C Q
- K C S (E,G)=0 F C=0:0 S C=$O(^LRD(65,A,9,C)) Q:'C S F=$P(^(C,0),"^",2),E=E+1,C(C)="" I "ABCDE"[$E(F,$L(F)) S C(C)=2
- S F=0 F C=0:0 S C=$O(C(C)) Q:'C S F=F+1 D S
- S:G $P(^LRD(65,A,4),"^",4)="("_G_")" Q
- S I F=E S $P(^LRD(65,A,9,C,0),"^",3)=2 Q
- I C(C) S $P(^LRD(65,A,9,C,0),"^",3)=2 Q
- S $P(^LRD(65,A,9,C,0),"^",3)=1,G=G+1 Q
- ;
- Q
- C F C=0:0 S C=$O(^LRD(65,A,9,C)) Q:'C S $P(^(C,0),"^",3)=P
- Q
- LRIPOS2 ;AVAMC/REG - SET DD(65.091,.03 PART OF LRINIT POST INITS V 5.2;7/23/92 12:39
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 ; If entries in MODIFIED/TO FROM FIELD then
- +5 ; If disposition not modified or no disposition put a 1 in the
- +6 ; ^DD(65.091,.03 field
- +7 ; If unit is whole blood put a 2 in the 3rd piece of the zero subscript
- +8 ; If divided unit put a 2 for each divided unit in 0;3
- +9 ; Should be only ran during the post init process
- +10 ; It does not do any harm to run this routine more than once.
- EN ;
- +1 IF '$DATA(DIFQ)
- QUIT
- +2 IF '$DATA(LRVR)!($GET(LRVR)>5.1)
- QUIT
- +3 WRITE !,"Updating the Modified/To From Field in the Blood Bank Module",!
- +4 FOR A=0:0
- SET A=$ORDER(^LRD(65,A))
- IF 'A
- QUIT
- IF $ORDER(^LRD(65,A,9,0))
- SET B=$SELECT($DATA(^LRD(65,A,4)):$PIECE(^(4),"^"),1:1)
- DO A
- ADSOL IF '$ORDER(^LRE(0))
- QUIT
- +1 ;for ^DD(65.54,4.11,0) entries
- WRITE !!,"Changing ADSOL to CPD in the Donor file (#65.5) ^LRE( ",!
- +2 SET I=0
- FOR
- SET I=$ORDER(^LRE(I))
- IF 'I
- QUIT
- SET LRI=0
- FOR
- SET LRI=$ORDER(^LRE(I,5,LRI))
- IF 'LRI
- QUIT
- SET Y=$PIECE($GET(^(LRI,2)),"^",9)
- IF Y=4
- SET $PIECE(^(2),"^",9)=1
- +3 WRITE !,"Your file has been adjusted",!
- +4 QUIT
- A IF '(A#100)
- WRITE "."
- IF B'="MO"
- SET P=1
- DO C
- QUIT
- +1 IF $SELECT('$PIECE($GET(^LRD(65,A,0)),"^",4):1,'$DATA(^LAB(66,$PIECE(^LRD(65,A,0),"^",4),0)):1,1:0)
- WRITE !,"^LRD(65,",A,",entry corrupted or no entry in 4th piece of 0th subscript",!,"or no component entry in file 66 for unit",!
- QUIT
- +2 IF $PIECE(^LAB(66,$PIECE(^LRD(65,A,0),"^",4),0),"^",26)=1
- SET P=2
- DO C
- QUIT
- +3 KILL C
- SET (E,G)=0
- FOR C=0:0
- SET C=$ORDER(^LRD(65,A,9,C))
- IF 'C
- QUIT
- SET F=$PIECE(^(C,0),"^",2)
- SET E=E+1
- SET C(C)=""
- IF "ABCDE"[$EXTRACT(F,$LENGTH(F))
- SET C(C)=2
- +4 SET F=0
- FOR C=0:0
- SET C=$ORDER(C(C))
- IF 'C
- QUIT
- SET F=F+1
- DO S
- +5 IF G
- SET $PIECE(^LRD(65,A,4),"^",4)="("_G_")"
- QUIT
- S IF F=E
- SET $PIECE(^LRD(65,A,9,C,0),"^",3)=2
- QUIT
- +1 IF C(C)
- SET $PIECE(^LRD(65,A,9,C,0),"^",3)=2
- QUIT
- +2 SET $PIECE(^LRD(65,A,9,C,0),"^",3)=1
- SET G=G+1
- QUIT
- +3 ;
- +4 QUIT
- C FOR C=0:0
- SET C=$ORDER(^LRD(65,A,9,C))
- IF 'C
- QUIT
- SET $PIECE(^(C,0),"^",3)=P
- +1 QUIT
