- LRBLPE ; IHS/HQT/MJL - BB DATA ENTRY BY ACC # ;
- ;;5.2;LR;**1010**;MAR 01, 2001
- ;;5.2;LAB SERVICE;**35,72,100,121**;Sep 27, 1994
- D EN^LRBLPE1 G:'$D(LRAA) END
- L R !!,"Select Accession Number: ",LRAN:DTIME G:LRAN=""!(LRAN[U) END I LRAN'?1N.N W $C(7)," Enter numbers only." G L
- S (LR(1),LR(2))="" D REST G L
- REST W " for ",LRH(0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q
- N LRODT,LRSN S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRSVC=$P(X,"^",9),LRLLOC=$P(X,"^",7),LRDFN=+X,LRODT=$P(X,"^",4),LRSN=$P(X,"^",5) Q:'$D(^LR(LRDFN,0)) S X=^(0)
- S LRABO=$P(X,"^",5),LRRH=$P(X,"^",6),DFN=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_DFN_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU
- S S=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"") I +S S S=$S($D(^LAB(61,+S,0)):$P(^(0),"^"),1:"")
- W !,LRP," ID: ",SSN," ABO: ",LRABO," Rh: ",LRRH,!,"Specimen: ",S D ^LRDPA2 W !
- S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
- F LRT=0:0 S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:'LRT I $P(^LAB(60,LRT,0),"^",4)'="WK" D TEST
- Q
- TEST S (LRW(2.1),LRW(2.4),LRW(2.6),LRW)=0 I $P(^LAB(60,LRT,0),"^",4)'=LRSS W $C(7),!!,$P(^(0),"^")," does not belong in ",LRAA(1)," accession area !",!,"Test deleted",!! D K^LRBLPE1 Q
- I '$D(LRT(LRT)) S X=^LAB(60,LRT,0),Y=$P(X,"^",14),LRT(LRT)=$P(X,"^") I Y,$D(^LAB(62.07,Y,.1)) S X=Y,Y=^(.1),LRT(LRT)=LRT(LRT)_"^"_Y_"^"_X
- I $P(LRT(LRT),"^",2)="" W $C(7),!!,"Cannot continue without execute code for ",$P(LRT(LRT),U) Q
- K L W !,"Test:",$P(LRT(LRT),"^") X $P(LRT(LRT),"^",2) S DIE="^LR(",DA=LRDFN L +^LR(LRDFN,"BB"):1 I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" Q
- D:DR="[LRBLPAG]" PH
- ;W ! D ^DIE L -^LR(LRDFN,"BB") D OR D:'$D(Y) ^LRBLPEW D:DR="[LRBLPAG]" SET D:$D(LRMED) ^LRBLPE1
- ;W ! D ^DIE L -^LR(LRDFN,"BB") D OR D:BLRLOG ^BLRSLTL("M","R","BBANK") D:'$D(Y) ^LRBLPEW D:DR="[LRBLPAG]" SET D:$D(LRMED) ^LRBLPE1 ;IHS/OIRM TUC/AAB 01/16/97
- W ! D ^DIE L -^LR(LRDFN,"BB") D OR D:BLRLOG ^BLREVTQ("M","R","BBANK",,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN) D:'$D(Y) ^LRBLPEW D:DR="[LRBLPAG]" SET D:$D(LRMED) ^LRBLPE1
- D
- . N CORRECT S CORRECT=0 I $P($G(^LR(LRDFN,"BB",+LRI,0)),"^",3) S CORRECT=1
- . D NEW^LR7OB1(LRODT,LRSN,"RE")
- K DA,DIE,DR,LRMED Q
- ;
- PH I '$O(^LR(LRDFN,1,0)),'$O(^LR(LRDFN,1.5,0)) Q
- W !?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%"),!,"Patient's Phenotype Record:"
- S E=1,(F(1),G)="" F B=0:0 S B=$O(^LR(LRDFN,1,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),F(E)=F(E)_I_" ",G=G+1 I $L(F(E))>19 S F(E)=$P(F(E)," ",1,G-1),E=E+1,F(E)=I_" ",G=""
- S K=E,E=1,(J(1),G)="" F B=0:0 S B=$O(^LR(LRDFN,1.5,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),J(E)=J(E)_I_" ",G=G+1 I $L(J(E))>18 S J(E)=$P(J(E)," ",1,G-1),E=E+1,J(E)=I_" ",G=""
- S:E>K K=E F E=1:1:K W:E>1 ! W:$D(F(E)) ?40,$J(F(E),19) W:$D(J(E)) ?60,"|",$J(J(E),18)
- Q
- SET S C=0 F A=0:0 S A=$O(^LR(LRDFN,"BB",LRI,1.1,A)) Q:'A I '$D(^LR(LRDFN,1,A)) S ^(A,0)=A,C=C+1
- I C S:'$D(^LR(LRDFN,1,0)) ^(0)="^63.13PA^^" S X=^(0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)+1)
- S C=0 F A=0:0 S A=$O(^LR(LRDFN,"BB",LRI,1.2,A)) Q:'A I '$D(^LR(LRDFN,1.5,A)) S ^(A,0)=A,C=C+1
- I C S:'$D(^LR(LRDFN,1.5,0)) ^(0)="^63.016PA^^" S X=^(0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)+1)
- S DA(2)=LRDFN,DA(1)=LRI F LRM=0:0 S LRM=$O(LRM(LRM)) Q:'LRM F M=0:0 S M=$O(LRM(LRM,M)) Q:'M I '$D(^LR(LRDFN,"BB",LRI,LRM,M)) S O=M,X="deleted",Z=LRM(LRM,M)_",.01" D EN^LRUD
- K M,LRM,O Q
- END D V^LRU Q
- OR ;Call to OE/RR 2.5 status update
- I $$VER^LR7OU1>2.5 Q
- N LRODT,LRSN,LRTST,LRIEN
- ;S LRODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",4),LRSN=$P(^(0),"^",5),LRTST=$O(^(4,0)) Q:LRTST<1
- S LRODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",4),LRSN=$P(^(0),"^",5),LRTST=$O(^(4,0)),BLRODT=LRODT,BLRSEQ=LRSN Q:LRTST<1 ;IHS/OIRM TUC/AAB 01/16/97
- I $D(^LRO(69,LRODT,1,LRSN,2)) S LRIEN=$O(^(2,"B",LRTST,0)) Q:LRIEN<1 S ORIFN=$P(^LRO(69,LRODT,1,LRSN,2,LRIEN,0),"^",7)
- ;S ORETURN("ORSTS")=2 D RETURN^ORX
- S ORETURN("ORSTS")=2 D RETURN^BLRORX ;IHS/DIR TUC/AAB 06/15/98
- Q
- LRBLPE ; IHS/HQT/MJL - BB DATA ENTRY BY ACC # ;
- +1 ;;5.2;LR;**1010**;MAR 01, 2001
- +2 ;;5.2;LAB SERVICE;**35,72,100,121**;Sep 27, 1994
- +3 DO EN^LRBLPE1
- IF '$DATA(LRAA)
- GOTO END
- L READ !!,"Select Accession Number: ",LRAN:DTIME
- IF LRAN=""!(LRAN[U)
- GOTO END
- IF LRAN'?1N.N
- WRITE $CHAR(7)," Enter numbers only."
- GOTO L
- +1 SET (LR(1),LR(2))=""
- DO REST
- GOTO L
- REST WRITE " for ",LRH(0)
- IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!!
- QUIT
- +1 NEW LRODT,LRSN
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- SET LRSVC=$PIECE(X,"^",9)
- SET LRLLOC=$PIECE(X,"^",7)
- SET LRDFN=+X
- SET LRODT=$PIECE(X,"^",4)
- SET LRSN=$PIECE(X,"^",5)
- IF '$DATA(^LR(LRDFN,0))
- QUIT
- SET X=^(0)
- +2 SET LRABO=$PIECE(X,"^",5)
- SET LRRH=$PIECE(X,"^",6)
- SET DFN=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET X=@(X_DFN_",0)")
- SET LRP=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- DO SSN^LRU
- +3 SET S=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
- IF +S
- SET S=$SELECT($DATA(^LAB(61,+S,0)):$PIECE(^(0),"^"),1:"")
- +4 WRITE !,LRP," ID: ",SSN," ABO: ",LRABO," Rh: ",LRRH,!,"Specimen: ",S
- DO ^LRDPA2
- WRITE !
- +5 SET LRI=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
- +6 FOR LRT=0:0
- SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
- IF 'LRT
- QUIT
- IF $PIECE(^LAB(60,LRT,0),"^",4)'="WK"
- DO TEST
- +7 QUIT
- TEST SET (LRW(2.1),LRW(2.4),LRW(2.6),LRW)=0
- IF $PIECE(^LAB(60,LRT,0),"^",4)'=LRSS
- WRITE $CHAR(7),!!,$PIECE(^(0),"^")," does not belong in ",LRAA(1)," accession area !",!,"Test deleted",!!
- DO K^LRBLPE1
- QUIT
- +1 IF '$DATA(LRT(LRT))
- SET X=^LAB(60,LRT,0)
- SET Y=$PIECE(X,"^",14)
- SET LRT(LRT)=$PIECE(X,"^")
- IF Y
- IF $DATA(^LAB(62.07,Y,.1))
- SET X=Y
- SET Y=^(.1)
- SET LRT(LRT)=LRT(LRT)_"^"_Y_"^"_X
- +2 IF $PIECE(LRT(LRT),"^",2)=""
- WRITE $CHAR(7),!!,"Cannot continue without execute code for ",$PIECE(LRT(LRT),U)
- QUIT
- +3 KILL L
- WRITE !,"Test:",$PIECE(LRT(LRT),"^")
- XECUTE $PIECE(LRT(LRT),"^",2)
- SET DIE="^LR("
- SET DA=LRDFN
- LOCK +^LR(LRDFN,"BB"):1
- IF '$TEST
- WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!"
- QUIT
- +4 IF DR="[LRBLPAG]"
- DO PH
- +5 ;W ! D ^DIE L -^LR(LRDFN,"BB") D OR D:'$D(Y) ^LRBLPEW D:DR="[LRBLPAG]" SET D:$D(LRMED) ^LRBLPE1
- +6 ;W ! D ^DIE L -^LR(LRDFN,"BB") D OR D:BLRLOG ^BLRSLTL("M","R","BBANK") D:'$D(Y) ^LRBLPEW D:DR="[LRBLPAG]" SET D:$D(LRMED) ^LRBLPE1 ;IHS/OIRM TUC/AAB 01/16/97
- +7 WRITE !
- DO ^DIE
- LOCK -^LR(LRDFN,"BB")
- DO OR
- IF BLRLOG
- DO ^BLREVTQ("M","R","BBANK",,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN)
- IF '$DATA(Y)
- DO ^LRBLPEW
- IF DR="[LRBLPAG]"
- DO SET
- IF $DATA(LRMED)
- DO ^LRBLPE1
- +8 Begin DoDot:1
- +9 NEW CORRECT
- SET CORRECT=0
- IF $PIECE($GET(^LR(LRDFN,"BB",+LRI,0)),"^",3)
- SET CORRECT=1
- +10 DO NEW^LR7OB1(LRODT,LRSN,"RE")
- End DoDot:1
- +11 KILL DA,DIE,DR,LRMED
- QUIT
- +12 ;
- PH IF '$ORDER(^LR(LRDFN,1,0))
- IF '$ORDER(^LR(LRDFN,1.5,0))
- QUIT
- +1 WRITE !?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%"),!,"Patient's Phenotype Record:"
- +2 SET E=1
- SET (F(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LR(LRDFN,1,B))
- IF 'B
- QUIT
- SET I=$PIECE(^LAB(61.3,B,0),"^")
- SET F(E)=F(E)_I_" "
- SET G=G+1
- IF $LENGTH(F(E))>19
- SET F(E)=$PIECE(F(E)," ",1,G-1)
- SET E=E+1
- SET F(E)=I_" "
- SET G=""
- +3 SET K=E
- SET E=1
- SET (J(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LR(LRDFN,1.5,B))
- IF 'B
- QUIT
- SET I=$PIECE(^LAB(61.3,B,0),"^")
- SET J(E)=J(E)_I_" "
- SET G=G+1
- IF $LENGTH(J(E))>18
- SET J(E)=$PIECE(J(E)," ",1,G-1)
- SET E=E+1
- SET J(E)=I_" "
- SET G=""
- +4 IF E>K
- SET K=E
- FOR E=1:1:K
- IF E>1
- WRITE !
- IF $DATA(F(E))
- WRITE ?40,$JUSTIFY(F(E),19)
- IF $DATA(J(E))
- WRITE ?60,"|",$JUSTIFY(J(E),18)
- +5 QUIT
- SET SET C=0
- FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,"BB",LRI,1.1,A))
- IF 'A
- QUIT
- IF '$DATA(^LR(LRDFN,1,A))
- SET ^(A,0)=A
- SET C=C+1
- +1 IF C
- IF '$DATA(^LR(LRDFN,1,0))
- SET ^(0)="^63.13PA^^"
- SET X=^(0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)+1)
- +2 SET C=0
- FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,"BB",LRI,1.2,A))
- IF 'A
- QUIT
- IF '$DATA(^LR(LRDFN,1.5,A))
- SET ^(A,0)=A
- SET C=C+1
- +3 IF C
- IF '$DATA(^LR(LRDFN,1.5,0))
- SET ^(0)="^63.016PA^^"
- SET X=^(0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)+1)
- +4 SET DA(2)=LRDFN
- SET DA(1)=LRI
- FOR LRM=0:0
- SET LRM=$ORDER(LRM(LRM))
- IF 'LRM
- QUIT
- FOR M=0:0
- SET M=$ORDER(LRM(LRM,M))
- IF 'M
- QUIT
- IF '$DATA(^LR(LRDFN,"BB",LRI,LRM,M))
- SET O=M
- SET X="deleted"
- SET Z=LRM(LRM,M)_",.01"
- DO EN^LRUD
- +5 KILL M,LRM,O
- QUIT
- END DO V^LRU
- QUIT
- OR ;Call to OE/RR 2.5 status update
- +1 IF $$VER^LR7OU1>2.5
- QUIT
- +2 NEW LRODT,LRSN,LRTST,LRIEN
- +3 ;S LRODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",4),LRSN=$P(^(0),"^",5),LRTST=$O(^(4,0)) Q:LRTST<1
- +4 ;IHS/OIRM TUC/AAB 01/16/97
- SET LRODT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",4)
- SET LRSN=$PIECE(^(0),"^",5)
- SET LRTST=$ORDER(^(4,0))
- SET BLRODT=LRODT
- SET BLRSEQ=LRSN
- IF LRTST<1
- QUIT
- +5 IF $DATA(^LRO(69,LRODT,1,LRSN,2))
- SET LRIEN=$ORDER(^(2,"B",LRTST,0))
- IF LRIEN<1
- QUIT
- SET ORIFN=$PIECE(^LRO(69,LRODT,1,LRSN,2,LRIEN,0),"^",7)
- +6 ;S ORETURN("ORSTS")=2 D RETURN^ORX
- +7 ;IHS/DIR TUC/AAB 06/15/98
- SET ORETURN("ORSTS")=2
- DO RETURN^BLRORX
- +8 QUIT
