- LRBLJED ; IHS/DIR/AAB - BB INVENTORY EDIT 3/3/97 13:20 ; [ 05/28/98 2:04 PM ]
- ;;5.2;LR;**1002,1003**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72,90**;Sep 27, 1994
- ;
- D D G G:Y<1 END D CK^LRU G:$D(LR("CK")) D S DR="[LRBLIDTM]" D ^DIE D FRE^LRU D:$D(LRT) FX G D
- E D G G:Y<1 END D CK^LRU G:$D(LR("CK")) E S DR="[LRBLIXR]" D ^DIE D FRE^LRU G E
- L D G G:Y<1 END D CK^LRU G:$D(LR("CK")) L S LR(0)=$P(Y,U,2),LR(4)=$P(Y(0),U,4) W !!,LR(0),"// " R X:DTIME G L:X[U!('$T),DIE:X="" I X'="@" X $P(^DD(65,.01,0),U,5,99) I '$D(X) W !,$C(7),$G(^DD(65,.01,3)) X:$D(^(4)) ^(4) G L
- S LR(1)=DA I X="@" W $C(7),!?3,"SURE YOU WANT TO DELETE THE ENTIRE '",LR(0),"' BLOOD INVENTORY" S %=2 D YN^LRU G:%'=1 L I %=1 S O=LR(0),X="Deleted",Z="65,.01" D EN^LRUD S LR="@",DR=".01///^S X=LR" D ^DIE G L
- D W G:'$D(X) L S LR=X,DR=".01///^S X=LR" D ^DIE S O=LR(0),Z="65,.01" D EN^LRUD
- DIE S DR="[LRBLILG]" D ^DIE I $D(DA),$P(^LRD(65,DA,0),U)'=LR(65,.01) D KK^LRBLU
- D FRE^LRU G L
- ;
- G D END S X="BLOOD BANK",LRAA(2)="BB" D BB^LRUTL
- S DIC=68,DIC(0)="MOXZ" I X="" S DIC(0)="AEMQZ"
- D ^DIC K DIC S LRAA=+Y
- W ! S (DIC,DIE)="^LRD(65,",DIC(0)="AEFQMZ",DIC("S")="I $P(^(0),U,16)=DUZ(2)" D ^DIC K DIC Q:Y<1
- S (DA,LR("UNIT"))=+Y,LR(65,.01)=$P(Y,U,2),X=$P(^VA(200,DUZ,0),"^",2) D C^LRUA S LRWHO=X Q
- ;
- FX Q:'$D(^LRD(65,DA,6)) S T(9)="",T=LRT,T(1)=LRT(1),W=^(0),X=^(6),T(3)="",T(4)=$P(X,"^",4),T(5)=$P(X,"^",5),T(11)=$P(X,"^",8) I T,T(4),$D(^LR(T,1.6,T(4),0)) S T(0)=^(0),T(9)=$P(T(0),U,9) D KL
- Q:'T(1) S:'$D(^LR(T(1),1.6,0)) ^(0)="^63.017DAI^^" S:$D(^LRD(65,DA,9,0)) T(3)=$P(^(0),"^",4) L +^LR(T(1),1.6):5 I '$T W !,"I can't do this right now. Someone else is editing this record. " Q
- FC I $D(^LR(T(1),1.6,LRI)) S LRI=LRI-.00001 G FC
- S T(10)=$P(^LRD(65,DA,0),"^",11)
- S ^LR(T(1),1.6,LRI,0)=LRQ_"^"_$P(W,"^",4)_"^"_$P(W,"^")_"^"_DUZ_"^"_$P(W,"^",7)_"^"_$P(W,"^",8)_"^"_T(3)_"^"_T(5)_"^"_T(9)_"^"_T(10)_"^"_T(11),X=^LR(T(1),1.6,0),^(0)=$P(X,"^",1,2)_"^"_LRI_"^"_($P(X,"^",4)+1) L -^LR(T(1),1.6)
- I T(11) S ^LR("AB",T(1),T(11),LRI)=""
- S $P(^LRD(65,DA,6),"^",4)=LRI S E=0 F A=1:1 S E=$O(^LRD(65,DA,7,E)) Q:'E S E(2)=^(E,0),^LR(T(1),1.6,LRI,1,A,0)=E(2)
- S:A>1 ^LR(T(1),1.6,LRI,1,0)="^63.186A^"_(A-1)_"^"_(A-1)
- I LRO(1)'=LRW(9) S LRREC=LRI,LRPTR=T(1) D DISP5^LRBLAUD1 ; Adds patient transfusion record data to the audit trail
- Q
- KL L +^LR(T,1.6):5 I '$T W !,"Someone else is editing this entry. Try again later " Q
- K ^LR(T,1.6,T(4)),^LR("AB",T,+$P(T(0),U,11),T(4)) S X(1)=$O(^LR(T,1.6,0)) S:'X(1) X(1)=0 S X=^LR(T,1.6,0),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)=0:X(1),1:($P(X,"^",4)-1)) L -^LR(T,1.6)
- Q
- ;
- A D G G:Y<1 END I '$D(^LRD(65,DA,8)) W !?7,"No autologous/directed donor entry for this unit." G A
- S W=^LRD(65,DA,8),(X,LRX)=+(W),W=$P(W,"^",2),W(3)=$S($P(W,"^",3)="A":"Autologous ","D":"Directed ",1:"")_"donation" I 'X W !?7,"Donor unit has been released to stock.",! G A
- I W!(W="") W:W !?7,"One or more screening tests from ",W(3)," are positive." W:W="" !?7,"Not all screening tests completed." W !?7,$C(7),"DELETION NOT ALLOWED !",! G A
- ;W !,$P(W(3)," ")," donor: " S X=^LR(X,0),(LRDPF,Y)=$P(X,"^",2),X=$P(X,"^",3),Y=^DIC(Y,0,"GL"),X=@(Y_X_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU W LRP," ",SSN," OK TO DELETE " S %=1 D YN^LRU Q:%'=1
- W !,$P(W(3)," ")," donor: " S X=^LR(X,0),(LRDPF,Y)=$P(X,"^",2),(DFN,X)=$P(X,"^",3),Y=^DIC(Y,0,"GL"),X=@(Y_X_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU W LRP," ",HRCN," OK TO DELETE " S %=1 D YN^LRU Q:%'=1 ;IHS/DIR TUC/AAB 04/29/98
- S ^LRD(65,DA,8)="^"_W K ^LRD(65,"AU",LRX,DA) Q
- ;
- W S X(1)=+$P($G(^LRD(65,DA,0)),"^",4),X(2)=0 F S X(2)=$O(^LRD(65,"B",X,X(2))) Q:'X(2) I $P(^LRD(65,X(2),0),"^",4)=X(1) D W1 Q
- Q
- W1 W $C(7),!,$P(^LAB(66,$P(^LRD(65,X(2),0),U,4),0),U)," unit already exists in inventory" K X Q
- ;
- END D V^LRU Q
- LRBLJED ; IHS/DIR/AAB - BB INVENTORY EDIT 3/3/97 13:20 ; [ 05/28/98 2:04 PM ]
- +1 ;;5.2;LR;**1002,1003**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72,90**;Sep 27, 1994
- +3 ;
- D DO G
- IF Y<1
- GOTO END
- DO CK^LRU
- IF $DATA(LR("CK"))
- GOTO D
- SET DR="[LRBLIDTM]"
- DO ^DIE
- DO FRE^LRU
- IF $DATA(LRT)
- DO FX
- GOTO D
- E DO G
- IF Y<1
- GOTO END
- DO CK^LRU
- IF $DATA(LR("CK"))
- GOTO E
- SET DR="[LRBLIXR]"
- DO ^DIE
- DO FRE^LRU
- GOTO E
- L DO G
- IF Y<1
- GOTO END
- DO CK^LRU
- IF $DATA(LR("CK"))
- GOTO L
- SET LR(0)=$PIECE(Y,U,2)
- SET LR(4)=$PIECE(Y(0),U,4)
- WRITE !!,LR(0),"// "
- READ X:DTIME
- IF X[U!('$TEST)
- GOTO L
- IF X=""
- GOTO DIE
- IF X'="@"
- XECUTE $PIECE(^DD(65,.01,0),U,5,99)
- IF '$DATA(X)
- WRITE !,$CHAR(7),$GET(^DD(65,.01,3))
- IF $DATA(^(4))
- XECUTE ^(4)
- GOTO L
- +1 SET LR(1)=DA
- IF X="@"
- WRITE $CHAR(7),!?3,"SURE YOU WANT TO DELETE THE ENTIRE '",LR(0),"' BLOOD INVENTORY"
- SET %=2
- DO YN^LRU
- IF %'=1
- GOTO L
- IF %=1
- SET O=LR(0)
- SET X="Deleted"
- SET Z="65,.01"
- DO EN^LRUD
- SET LR="@"
- SET DR=".01///^S X=LR"
- DO ^DIE
- GOTO L
- +2 DO W
- IF '$DATA(X)
- GOTO L
- SET LR=X
- SET DR=".01///^S X=LR"
- DO ^DIE
- SET O=LR(0)
- SET Z="65,.01"
- DO EN^LRUD
- DIE SET DR="[LRBLILG]"
- DO ^DIE
- IF $DATA(DA)
- IF $PIECE(^LRD(65,DA,0),U)'=LR(65,.01)
- DO KK^LRBLU
- +1 DO FRE^LRU
- GOTO L
- +2 ;
- G DO END
- SET X="BLOOD BANK"
- SET LRAA(2)="BB"
- DO BB^LRUTL
- +1 SET DIC=68
- SET DIC(0)="MOXZ"
- IF X=""
- SET DIC(0)="AEMQZ"
- +2 DO ^DIC
- KILL DIC
- SET LRAA=+Y
- +3 WRITE !
- SET (DIC,DIE)="^LRD(65,"
- SET DIC(0)="AEFQMZ"
- SET DIC("S")="I $P(^(0),U,16)=DUZ(2)"
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- +4 SET (DA,LR("UNIT"))=+Y
- SET LR(65,.01)=$PIECE(Y,U,2)
- SET X=$PIECE(^VA(200,DUZ,0),"^",2)
- DO C^LRUA
- SET LRWHO=X
- QUIT
- +5 ;
- FX IF '$DATA(^LRD(65,DA,6))
- QUIT
- SET T(9)=""
- SET T=LRT
- SET T(1)=LRT(1)
- SET W=^(0)
- SET X=^(6)
- SET T(3)=""
- SET T(4)=$PIECE(X,"^",4)
- SET T(5)=$PIECE(X,"^",5)
- SET T(11)=$PIECE(X,"^",8)
- IF T
- IF T(4)
- IF $DATA(^LR(T,1.6,T(4),0))
- SET T(0)=^(0)
- SET T(9)=$PIECE(T(0),U,9)
- DO KL
- +1 IF 'T(1)
- QUIT
- IF '$DATA(^LR(T(1),1.6,0))
- SET ^(0)="^63.017DAI^^"
- IF $DATA(^LRD(65,DA,9,0))
- SET T(3)=$PIECE(^(0),"^",4)
- LOCK +^LR(T(1),1.6):5
- IF '$TEST
- WRITE !,"I can't do this right now. Someone else is editing this record. "
- QUIT
- FC IF $DATA(^LR(T(1),1.6,LRI))
- SET LRI=LRI-.00001
- GOTO FC
- +1 SET T(10)=$PIECE(^LRD(65,DA,0),"^",11)
- +2 SET ^LR(T(1),1.6,LRI,0)=LRQ_"^"_$PIECE(W,"^",4)_"^"_$PIECE(W,"^")_"^"_DUZ_"^"_$PIECE(W,"^",7)_"^"_$PIECE(W,"^",8)_"^"_T(3)_"^"_T(5)_"^"_T(9)_"^"_T(10)_"^"_T(11)
- SET X=^LR(T(1),1.6,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRI_"^"_($PIECE(X,"^",4)+1)
- LOCK -^LR(T(1),1.6)
- +3 IF T(11)
- SET ^LR("AB",T(1),T(11),LRI)=""
- +4 SET $PIECE(^LRD(65,DA,6),"^",4)=LRI
- SET E=0
- FOR A=1:1
- SET E=$ORDER(^LRD(65,DA,7,E))
- IF 'E
- QUIT
- SET E(2)=^(E,0)
- SET ^LR(T(1),1.6,LRI,1,A,0)=E(2)
- +5 IF A>1
- SET ^LR(T(1),1.6,LRI,1,0)="^63.186A^"_(A-1)_"^"_(A-1)
- +6 ; Adds patient transfusion record data to the audit trail
- IF LRO(1)'=LRW(9)
- SET LRREC=LRI
- SET LRPTR=T(1)
- DO DISP5^LRBLAUD1
- +7 QUIT
- KL LOCK +^LR(T,1.6):5
- IF '$TEST
- WRITE !,"Someone else is editing this entry. Try again later "
- QUIT
- +1 KILL ^LR(T,1.6,T(4)),^LR("AB",T,+$PIECE(T(0),U,11),T(4))
- SET X(1)=$ORDER(^LR(T,1.6,0))
- IF 'X(1)
- SET X(1)=0
- SET X=^LR(T,1.6,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)=0:X(1),1:($PIECE(X,"^",4)-1))
- LOCK -^LR(T,1.6)
- +2 QUIT
- +3 ;
- A DO G
- IF Y<1
- GOTO END
- IF '$DATA(^LRD(65,DA,8))
- WRITE !?7,"No autologous/directed donor entry for this unit."
- GOTO A
- +1 SET W=^LRD(65,DA,8)
- SET (X,LRX)=+(W)
- SET W=$PIECE(W,"^",2)
- SET W(3)=$SELECT($PIECE(W,"^",3)="A":"Autologous ","D":"Directed ",1:"")_"donation"
- IF 'X
- WRITE !?7,"Donor unit has been released to stock.",!
- GOTO A
- +2 IF W!(W="")
- IF W
- WRITE !?7,"One or more screening tests from ",W(3)," are positive."
- IF W=""
- WRITE !?7,"Not all screening tests completed."
- WRITE !?7,$CHAR(7),"DELETION NOT ALLOWED !",!
- GOTO A
- +3 ;W !,$P(W(3)," ")," donor: " S X=^LR(X,0),(LRDPF,Y)=$P(X,"^",2),X=$P(X,"^",3),Y=^DIC(Y,0,"GL"),X=@(Y_X_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU W LRP," ",SSN," OK TO DELETE " S %=1 D YN^LRU Q:%'=1
- +4 ;IHS/DIR TUC/AAB 04/29/98
- WRITE !,$PIECE(W(3)," ")," donor: "
- SET X=^LR(X,0)
- SET (LRDPF,Y)=$PIECE(X,"^",2)
- SET (DFN,X)=$PIECE(X,"^",3)
- SET Y=^DIC(Y,0,"GL")
- SET X=@(Y_X_",0)")
- SET LRP=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- DO SSN^LRU
- WRITE LRP," ",HRCN," OK TO DELETE "
- SET %=1
- DO YN^LRU
- IF %'=1
- QUIT
- +5 SET ^LRD(65,DA,8)="^"_W
- KILL ^LRD(65,"AU",LRX,DA)
- QUIT
- +6 ;
- W SET X(1)=+$PIECE($GET(^LRD(65,DA,0)),"^",4)
- SET X(2)=0
- FOR
- SET X(2)=$ORDER(^LRD(65,"B",X,X(2)))
- IF 'X(2)
- QUIT
- IF $PIECE(^LRD(65,X(2),0),"^",4)=X(1)
- DO W1
- QUIT
- +1 QUIT
- W1 WRITE $CHAR(7),!,$PIECE(^LAB(66,$PIECE(^LRD(65,X(2),0),U,4),0),U)," unit already exists in inventory"
- KILL X
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
