LRBLJTS.m

LRBLJTS ; IHS/DIR/FJE - TRANSFUSION STATISTICS 4/12/93 15:19 ;

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END

 W !!?10,"Transfusion by treating specialty/physician",!

A R !!,"Start with TREATING SPECIALTY: FIRST// ",X:DTIME G:'$T!(X[U) END I X="" S LRA="/" G B

 S DIC="^DIC(45.7,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 A S X=$P(Y,"^",2),A=$A(X,$L(X))-1,A=$C(A),LRA=$E(X,1,$L(X)-1)_A_"z"

B R !,"Go    to   TREATING SPECIALTY: LAST// ",X:DTIME G:'$T!(X[U) END I X="" S LRB="{" G C

 S DIC="^DIC(45.7,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 B S LRB=$P(Y,"^",2)

C R !!,"Within TREATING SPECIALTY  Start with BLOOD COMPONENT: FIRST// ",X:DTIME G:'$T!(X[U) END I X="" S LRC="/" G D

 S DIC="^LAB(66,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 C S X=$P(Y,"^",2),A=$A($E(X,$L(X)))-1,A=$C(A),LRC=$E(X,1,$L(X)-1)_A_"z"

D R !,"Within TREATING SPECIALTY  Go    to   BLOOD COMPONENT: LAST// ",X:DTIME G:'$T!(X[U) END I X="" S LRE="{" G E

 S DIC="^LAB(66,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 D S LRE=$P(Y,"^",2)

E W !! D B^LRU Q:Y<0  S X=LRSDT,Y=LRLDT,LRQ(1)="("_+$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_"-"_+$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(X,2,3)_")"

 S ZTRTN="QUE^LRBLJTS" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO K ^TMP($J) S LRF("?")="?",LRSDT=LRSDT-.0001,LRLDT=LRLDT+.9999,X=$P(^DD(66,.26,0),U,3) F A=1:1 S B=$P(X,";",A) Q:B=""  S LRF($P(B,":"))=$P(B,":",2)

 D L^LRU,S^LRU,^LRBLJTS1

 D END^LRUTL,END Q

 ;

END D V^LRU Q

LRBLJTS   ; IHS/DIR/FJE - TRANSFUSION STATISTICS 4/12/93 15:19 ;

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        DO END

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               GOTO END

 +5        WRITE !!?10,"Transfusion by treating specialty/physician",!

A          READ !!,"Start with TREATING SPECIALTY: FIRST// ",X:DTIME

           IF '$TEST!(X[U)

               GOTO END

           IF X=""

               SET LRA="/"

               GOTO B

 +1        SET DIC="^DIC(45.7,"

           SET DIC(0)="EQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO A

           SET X=$PIECE(Y,"^",2)

           SET A=$ASCII(X,$LENGTH(X))-1

           SET A=$CHAR(A)

           SET LRA=$EXTRACT(X,1,$LENGTH(X)-1)_A_"z"

B          READ !,"Go    to   TREATING SPECIALTY: LAST// ",X:DTIME

           IF '$TEST!(X[U)

               GOTO END

           IF X=""

               SET LRB="{"

               GOTO C

 +1        SET DIC="^DIC(45.7,"

           SET DIC(0)="EQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO B

           SET LRB=$PIECE(Y,"^",2)

C          READ !!,"Within TREATING SPECIALTY  Start with BLOOD COMPONENT: FIRST// ",X:DTIME

           IF '$TEST!(X[U)

               GOTO END

           IF X=""

               SET LRC="/"

               GOTO D

 +1        SET DIC="^LAB(66,"

           SET DIC(0)="EQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO C

           SET X=$PIECE(Y,"^",2)

           SET A=$ASCII($EXTRACT(X,$LENGTH(X)))-1

           SET A=$CHAR(A)

           SET LRC=$EXTRACT(X,1,$LENGTH(X)-1)_A_"z"

D          READ !,"Within TREATING SPECIALTY  Go    to   BLOOD COMPONENT: LAST// ",X:DTIME

           IF '$TEST!(X[U)

               GOTO END

           IF X=""

               SET LRE="{"

               GOTO E

 +1        SET DIC="^LAB(66,"

           SET DIC(0)="EQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO D

           SET LRE=$PIECE(Y,"^",2)

E          WRITE !!

           DO B^LRU

           IF Y<0

               QUIT 

           SET X=LRSDT

           SET Y=LRLDT

           SET LRQ(1)="("_+$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_"-"_+$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(X,2,3)_")"

 +1        SET ZTRTN="QUE^LRBLJTS"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           KILL ^TMP($JOB)

           SET LRF("?")="?"

           SET LRSDT=LRSDT-.0001

           SET LRLDT=LRLDT+.9999

           SET X=$PIECE(^DD(66,.26,0),U,3)

           FOR A=1:1

               SET B=$PIECE(X,";",A)

               IF B=""

                   QUIT 

               SET LRF($PIECE(B,":"))=$PIECE(B,":",2)

 +1        DO L^LRU

           DO S^LRU

           DO ^LRBLJTS1

 +2        DO END^LRUTL

           DO END

           QUIT 

 +3       ;

END        DO V^LRU

           QUIT