- LRBLDMV ; IHS/DIR/FJE - MOVE BLOOD DONATION 12/19/94 11:53 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;**26**;Sep 27, 1994
- ;IHS/ANMC/CLS 11/1/95 blood donor file
- W !!?17,"Move a donation from one donor to another",!
- ASK D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END D REST G:Y=1 ASK
- ;
- REST W ! S DIC=65.5,DIC(0)="AEQMZ",DIC("A")="MOVE FROM DONOR: " D ^DIC Q:Y<1 S LRF=+Y D A
- I '$O(^LRE(LRF,5,0)) W $C(7),!!,"No donation date." Q
- W ! S DIC="^LRE(LRF,5," S DIC("A")=" DONATION DATE: " D ^DIC K DIC Q:Y<1 S LRI=+Y,LRU=$P(Y(0),U,4),(Y,LRD)=$P($P(Y(0),U),".") D D^LRU S LRD(1)=Y
- I LRU="" W $C(7),!,"No unit ID entered. Do you want to continue" S %=2 D YN^LRU Q:%'=1 S LRU="NONE"
- W " UNIT ID: ",LRU S DIE="^LRE(LRF,5,",DA=LRF D CK^LRU I $D(LR("CK")) D FRE^LRU Q
- W ! S DIC=65.5,DIC(0)="AEQMZ",DIC("A")="MOVE TO DONOR: " D ^DIC K DIC Q:Y<1 S LRT=+Y,LRT(1)=$P(Y,U,2) D A I $D(^LRE(LRT,5,LRI,0)) W $C(7),!!,"Donation date ",LRD(1)," exists for ",LRT(1) Q
- W $C(7),!!?3,"OK TO MOVE" S %=2 D YN^LRU I %'=1 D FRE^LRU Q
- S:'$D(^LRE(LRT,5,0)) ^(0)="^65.54DA^^"
- S %X="^LRE(LRF,5,LRI,",%Y="^LRE(LRT,5,LRI," D %XY^%RCR S X=^LRE(LRT,5,0),^(0)=$P(X,"^",1,2)_"^"_LRI_"^"_($P(X,"^",4)+1)
- K ^LRE(LRF,5,LRI),^LRE("AD",LRD,LRF),^LRE("C",LRU,LRF,LRI),^LRE("AT",LRU) S X=^LRE(LRF,5,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
- S ^LRE("AD",LRD,LRT)="",DA=LRI,DA(1)=LRT I LRU'="NONE" S ^LRE("C",LRU,LRT,LRI)="",X=LRU X ^DD(65.54,4,1,2,1)
- S Z="65.54,.01",X="",O=LRD,DA(1)=LRF D EN^LRUD S DA(1)=LRT,O="",X=LRD,Z="65.54,.01" D EN^LRUD
- D FRE^LRU S Y=1 Q
- F D E S A=0 F LRZ=0:1 S A=$O(^LRE(LR,99,A)) Q:'A S X=^LRE(LR,99,A,0) D ^DIWP
- D:LRZ ^DIWW Q
- E K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W" Q
- ;
- A S LRABO=$P(Y(0),U,5),LRRH=$P(Y(0),U,6) W !,"ABO GROUP: ",LRABO," Rh TYPE: ",LRRH
- S LR=+Y,X=$G(^LRE(LR,1)) W ?30,"File Number: ",LR,?50,"SSN: ",$P(Y(0),U,13),!,$P(X,U)," ",$P(X,U,2)," ",$P(X,U,3),!,$P(X,U,4)," ",$P($G(^DIC(5,+$P(X,U,5),0)),U)," ",$P(X,U,6)
- I $P(Y(0),U,10) W $C(7),!!," PERMANENT DEFERRAL " S Y=$P(Y(0),U,16) D D^LRU W " ",Y D F
- Q
- ;
- END D V^LRU Q
- LRBLDMV ; IHS/DIR/FJE - MOVE BLOOD DONATION 12/19/94 11:53 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;**26**;Sep 27, 1994
- +4 ;IHS/ANMC/CLS 11/1/95 blood donor file
- +5 WRITE !!?17,"Move a donation from one donor to another",!
- ASK DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- DO REST
- IF Y=1
- GOTO ASK
- +1 ;
- REST WRITE !
- SET DIC=65.5
- SET DIC(0)="AEQMZ"
- SET DIC("A")="MOVE FROM DONOR: "
- DO ^DIC
- IF Y<1
- QUIT
- SET LRF=+Y
- DO A
- +1 IF '$ORDER(^LRE(LRF,5,0))
- WRITE $CHAR(7),!!,"No donation date."
- QUIT
- +2 WRITE !
- SET DIC="^LRE(LRF,5,"
- SET DIC("A")=" DONATION DATE: "
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- SET LRI=+Y
- SET LRU=$PIECE(Y(0),U,4)
- SET (Y,LRD)=$PIECE($PIECE(Y(0),U),".")
- DO D^LRU
- SET LRD(1)=Y
- +3 IF LRU=""
- WRITE $CHAR(7),!,"No unit ID entered. Do you want to continue"
- SET %=2
- DO YN^LRU
- IF %'=1
- QUIT
- SET LRU="NONE"
- +4 WRITE " UNIT ID: ",LRU
- SET DIE="^LRE(LRF,5,"
- SET DA=LRF
- DO CK^LRU
- IF $DATA(LR("CK"))
- DO FRE^LRU
- QUIT
- +5 WRITE !
- SET DIC=65.5
- SET DIC(0)="AEQMZ"
- SET DIC("A")="MOVE TO DONOR: "
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- SET LRT=+Y
- SET LRT(1)=$PIECE(Y,U,2)
- DO A
- IF $DATA(^LRE(LRT,5,LRI,0))
- WRITE $CHAR(7),!!,"Donation date ",LRD(1)," exists for ",LRT(1)
- QUIT
- +6 WRITE $CHAR(7),!!?3,"OK TO MOVE"
- SET %=2
- DO YN^LRU
- IF %'=1
- DO FRE^LRU
- QUIT
- +7 IF '$DATA(^LRE(LRT,5,0))
- SET ^(0)="^65.54DA^^"
- +8 SET %X="^LRE(LRF,5,LRI,"
- SET %Y="^LRE(LRT,5,LRI,"
- DO %XY^%RCR
- SET X=^LRE(LRT,5,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRI_"^"_($PIECE(X,"^",4)+1)
- +9 KILL ^LRE(LRF,5,LRI),^LRE("AD",LRD,LRF),^LRE("C",LRU,LRF,LRI),^LRE("AT",LRU)
- SET X=^LRE(LRF,5,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- +10 SET ^LRE("AD",LRD,LRT)=""
- SET DA=LRI
- SET DA(1)=LRT
- IF LRU'="NONE"
- SET ^LRE("C",LRU,LRT,LRI)=""
- SET X=LRU
- XECUTE ^DD(65.54,4,1,2,1)
- +11 SET Z="65.54,.01"
- SET X=""
- SET O=LRD
- SET DA(1)=LRF
- DO EN^LRUD
- SET DA(1)=LRT
- SET O=""
- SET X=LRD
- SET Z="65.54,.01"
- DO EN^LRUD
- +12 DO FRE^LRU
- SET Y=1
- QUIT
- F DO E
- SET A=0
- FOR LRZ=0:1
- SET A=$ORDER(^LRE(LR,99,A))
- IF 'A
- QUIT
- SET X=^LRE(LR,99,A,0)
- DO ^DIWP
- +1 IF LRZ
- DO ^DIWW
- QUIT
- E KILL ^UTILITY($JOB)
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- QUIT
- +1 ;
- A SET LRABO=$PIECE(Y(0),U,5)
- SET LRRH=$PIECE(Y(0),U,6)
- WRITE !,"ABO GROUP: ",LRABO," Rh TYPE: ",LRRH
- +1 SET LR=+Y
- SET X=$GET(^LRE(LR,1))
- WRITE ?30,"File Number: ",LR,?50,"SSN: ",$PIECE(Y(0),U,13),!,$PIECE(X,U)," ",$PIECE(X,U,2)," ",$PIECE(X,U,3),!,$PIECE(X,U,4)," ",$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U)," ",$PIECE(X,U,6)
- +2 IF $PIECE(Y(0),U,10)
- WRITE $CHAR(7),!!," PERMANENT DEFERRAL "
- SET Y=$PIECE(Y(0),U,16)
- DO D^LRU
- WRITE " ",Y
- DO F
- +3 QUIT
- +4 ;
- END DO V^LRU
- QUIT
