- LRBLPT ; IHS/DIR/AAB - TRANSFUSION RESULTS 9/7/95 08:59 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
- W !!?28,"Enter transfusion results"
- ASK W ! K ^TMP($J),LRZ,LRA,DIC,DIE,DR D ^LRDPA G:LRDFN=-1 END D R G ASK
- ;
- R I '$D(^LRD(65,"AP",LRDFN)) W $C(7),!!,"No units currently assigned/xmatched.",! Q
- W ! S DIC("B")=LRMD,DIC="^VA(200,",DIC(0)="AEQ",D="AK.PROVIDER",DIC("A")="Select PROVIDER: " D IX^DIC Q:Y<1 S X=+Y,LRMD=$P(Y,U,2),LRMD(1)=+Y K DIC
- T W !!,"Select TREATING SPECIALTY: ",LRS,$S(LRS]"":"// ",1:"") R X:DTIME Q:X[U!'$T I X="",LRS="" Q
- S:X="" X=LRS I X["?" S DIC=45.7,DIC(0)="EM" D ^DIC K DIC W !,"You may select a specialty not in the treating specialty file." G T
- X $P(^DD(65,6.3,0),"^",5,99) I '$D(X) W $C(7),! W:$D(^(3)) ^(3) X:$D(^(4)) ^(4) G T
- S DIC="^DIC(45.7,",DIC(0)="EM" D ^DIC K DIC
- I Y<1 W $C(7),!,"Not an entry in the TREATING SPECIALTY file.",!,"Still want to accept it " S %=2 D YN^LRU I %'=1 S LRS="" G T
- S LRS=$S(Y>0:$P(Y,"^",2),1:X),LRS(1)=$S(Y>0:+Y,1:"")
- W ! S (LRA,LRZ)=0,LRG=1 F LRB=1:1 S LRA=$O(^LRD(65,"AP",LRDFN,LRA)) Q:'LRA D:LRB#20=0 M D N
- K LRG I LRZ=1 S LRV=1 G ^LRBLPT1
- SEL W !!,"Select units (1-",LRZ,") to enter TRANSFUSION results: " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter numbers from 1 to ",LRZ,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units." G SEL
- G:X="ALL" ALL
- I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed." G SEL
- I '+X W $C(7),!,"START with a NUMBER !!",! G SEL
- S LRQ=X F LRB=0:0 S LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:$D(^TMP($J,LRV)) ^LRBLPT1 Q:'$L(LRQ)
- Q
- ;
- N W:LRB=1 !?6,"Unit assigned/xmatched:",?48,"Exp date",?64,"Loc"
- I '$D(^LRD(65,LRA,0)) K ^LRD(65,"AP",LRDFN,LRA) Q
- Q:$P(^LRD(65,LRA,0),"^",16)'=DUZ(2) I '$P(^LRD(65,LRA,2,LRDFN,0),"^",3) S X=$O(^LRD(65,LRA,2,LRDFN,1,0)) S:X X=+^(X,0) S:X $P(^LRD(65,LRA,2,LRDFN,0),"^",3)=X
- S X=^LRD(65,LRA,0),F=$O(^(3,0)) S:F F=$P(^(F,0),"^",4) S:F="" F="Blood Bank"
- S M=$P(^LAB(66,$P(X,"^",4),0),"^"),LRZ=LRZ+1,^TMP($J,LRZ)=LRA_"^"_$P(X,"^",4)_"^"_$P(X,"^")_"^"_$P(X,"^",7)_"^"_$P(X,"^",8)_"^"_$P(^LRD(65,LRA,2,LRDFN,0),"^",3)_"^"_F W ! W:$D(LRG) $J(LRZ,2),") "
- W $P(X,"^"),?17,$E(M,1,22),?40,$J($P(X,"^",7),2),?43,$P(X,"^",8),?48 S Y=$P(X,"^",6) D DT^LRU W Y,?64,F Q
- ;
- ALL F LRV=0:0 S LRV=$O(^TMP($J,LRV)) Q:'LRV D ^LRBLPT1
- Q
- M R !,"Press RETURN",X:DTIME W $C(13),$J("",15),$C(13) Q
- END D V^LRU Q
- LRBLPT ; IHS/DIR/AAB - TRANSFUSION RESULTS 9/7/95 08:59 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- +4 WRITE !!?28,"Enter transfusion results"
- ASK WRITE !
- KILL ^TMP($JOB),LRZ,LRA,DIC,DIE,DR
- DO ^LRDPA
- IF LRDFN=-1
- GOTO END
- DO R
- GOTO ASK
- +1 ;
- R IF '$DATA(^LRD(65,"AP",LRDFN))
- WRITE $CHAR(7),!!,"No units currently assigned/xmatched.",!
- QUIT
- +1 WRITE !
- SET DIC("B")=LRMD
- SET DIC="^VA(200,"
- SET DIC(0)="AEQ"
- SET D="AK.PROVIDER"
- SET DIC("A")="Select PROVIDER: "
- DO IX^DIC
- IF Y<1
- QUIT
- SET X=+Y
- SET LRMD=$PIECE(Y,U,2)
- SET LRMD(1)=+Y
- KILL DIC
- T WRITE !!,"Select TREATING SPECIALTY: ",LRS,$SELECT(LRS]"":"// ",1:"")
- READ X:DTIME
- IF X[U!'$TEST
- QUIT
- IF X=""
- IF LRS=""
- QUIT
- +1 IF X=""
- SET X=LRS
- IF X["?"
- SET DIC=45.7
- SET DIC(0)="EM"
- DO ^DIC
- KILL DIC
- WRITE !,"You may select a specialty not in the treating specialty file."
- GOTO T
- +2 XECUTE $PIECE(^DD(65,6.3,0),"^",5,99)
- IF '$DATA(X)
- WRITE $CHAR(7),!
- IF $DATA(^(3))
- WRITE ^(3)
- IF $DATA(^(4))
- XECUTE ^(4)
- GOTO T
- +3 SET DIC="^DIC(45.7,"
- SET DIC(0)="EM"
- DO ^DIC
- KILL DIC
- +4 IF Y<1
- WRITE $CHAR(7),!,"Not an entry in the TREATING SPECIALTY file.",!,"Still want to accept it "
- SET %=2
- DO YN^LRU
- IF %'=1
- SET LRS=""
- GOTO T
- +5 SET LRS=$SELECT(Y>0:$PIECE(Y,"^",2),1:X)
- SET LRS(1)=$SELECT(Y>0:+Y,1:"")
- +6 WRITE !
- SET (LRA,LRZ)=0
- SET LRG=1
- FOR LRB=1:1
- SET LRA=$ORDER(^LRD(65,"AP",LRDFN,LRA))
- IF 'LRA
- QUIT
- IF LRB#20=0
- DO M
- DO N
- +7 KILL LRG
- IF LRZ=1
- SET LRV=1
- GOTO ^LRBLPT1
- SEL WRITE !!,"Select units (1-",LRZ,") to enter TRANSFUSION results: "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X["?"
- WRITE !,"Enter numbers from 1 to ",LRZ,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units."
- GOTO SEL
- +1 IF X="ALL"
- GOTO ALL
- +2 IF X?.E1CA.E!($LENGTH(X)>200)
- WRITE $CHAR(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed."
- GOTO SEL
- +3 IF '+X
- WRITE $CHAR(7),!,"START with a NUMBER !!",!
- GOTO SEL
- +4 SET LRQ=X
- FOR LRB=0:0
- SET LRV=+LRQ
- SET LRQ=$EXTRACT(LRQ,$LENGTH(LRV)+2,$LENGTH(LRQ))
- IF $DATA(^TMP($JOB,LRV))
- DO ^LRBLPT1
- IF '$LENGTH(LRQ)
- QUIT
- +5 QUIT
- +6 ;
- N IF LRB=1
- WRITE !?6,"Unit assigned/xmatched:",?48,"Exp date",?64,"Loc"
- +1 IF '$DATA(^LRD(65,LRA,0))
- KILL ^LRD(65,"AP",LRDFN,LRA)
- QUIT
- +2 IF $PIECE(^LRD(65,LRA,0),"^",16)'=DUZ(2)
- QUIT
- IF '$PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)
- SET X=$ORDER(^LRD(65,LRA,2,LRDFN,1,0))
- IF X
- SET X=+^(X,0)
- IF X
- SET $PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)=X
- +3 SET X=^LRD(65,LRA,0)
- SET F=$ORDER(^(3,0))
- IF F
- SET F=$PIECE(^(F,0),"^",4)
- IF F=""
- SET F="Blood Bank"
- +4 SET M=$PIECE(^LAB(66,$PIECE(X,"^",4),0),"^")
- SET LRZ=LRZ+1
- SET ^TMP($JOB,LRZ)=LRA_"^"_$PIECE(X,"^",4)_"^"_$PIECE(X,"^")_"^"_$PIECE(X,"^",7)_"^"_$PIECE(X,"^",8)_"^"_$PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)_"^"_F
- WRITE !
- IF $DATA(LRG)
- WRITE $JUSTIFY(LRZ,2),") "
- +5 WRITE $PIECE(X,"^"),?17,$EXTRACT(M,1,22),?40,$JUSTIFY($PIECE(X,"^",7),2),?43,$PIECE(X,"^",8),?48
- SET Y=$PIECE(X,"^",6)
- DO DT^LRU
- WRITE Y,?64,F
- QUIT
- +6 ;
- ALL FOR LRV=0:0
- SET LRV=$ORDER(^TMP($JOB,LRV))
- IF 'LRV
- QUIT
- DO ^LRBLPT1
- +1 QUIT
- M READ !,"Press RETURN",X:DTIME
- WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
- QUIT
- END DO V^LRU
- QUIT
