LRIPOS2.m

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