- LRBLPRA ;AVAMC/REG - BB PT RECORD ;2/18/93 09:46 ;
- ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- I LR(7),'$O(^LR(A,1.7,0)),'$O(^LR(A,3,0)) Q
- S W=^LR(A,0),Y=$P(W,"^",3),P=$P(W,"^",2),X=^DIC(P,0,"GL") Q:'$D(@(X_Y_",0)")) S X=^(0),^TMP("LRBL",$J,P,$P(X,"^"),A)=$P(X,"^",3)_"^"_$P(X,"^",9)_"^"_$P(W,"^",5)_"^"_$P(W,"^",6) Q
- ;
- EN D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
- W !!?20,"PRINT PATIENT BLOOD BANK RECORDS",!!
- W "Print only patients with antibodies/special instructions " S %=1,LR(7)=0 D YN^LRU G:%<1 END I %=1 S LR(7)=1
- ASK W !!,"Enter the maximum number of specimens to display",!,"in reverse chronological order for each patient: " R LR(8):DTIME Q:LR(8)=""!(LR(8)[U)
- I LR(8)'?1N.N!(LR(8)<0)!(LR(8)>99) W $C(7),!,"ENTER A WHOLE NUMBER FROM 0-99" G ASK
- S R !!,"START WITH PATIENT NAME: FIRST// ",X:DTIME G:X[U!'$T END I X="" S P(1)=0,P(2)="z" G T
- I X["?"!(X'?1U.E)!($L(X)>30) D H^LRU G S
- S P(1)=X I $L(X)>1 S X(1)=$A(X,$L(X))-1,X(1)=$C(X(1)),P(1)=$E(X,1,$L(X)-1)_X(1)
- F R !,"GO TO PATIENT NAME: LAST// ",X:DTIME G:X[U!'$T END I X="" S P(2)="z" G T
- I X["?"!(X'?1U.E)!($L(X)>30) D H1^LRU G F
- S P(2)=X
- T S ZTRTN="QUE^LRBLPRA" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP("LRBL",$J) D L^LRU,S^LRU
- F A=0:0 S A=$O(^LR(A)) Q:'A I $D(^(A,1.7))!($D(^(3)))!($D(^("BB"))) D LRBLPRA
- D H^LRBLPR S LR("F")=1
- F LR=0:0 S LR=$O(^TMP("LRBL",$J,LR)) Q:'LR!(LR("Q")) S LRP=P(1) F LR(1)=0:0 S LRP=$O(^TMP("LRBL",$J,LR,LRP)) Q:LRP=""!(LRP]P(2))!(LR("Q")) D B
- K ^TMP("LRBL",$J),^TMP($J) D END^LRUTL,END Q
- ;
- B F LRDFN=0:0 S LRDFN=$O(^TMP("LRBL",$J,LR,LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S LR(4)=^(LRDFN) D W
- Q
- W D:$Y>(IOSL-6) H^LRBLPR Q:LR("Q") S LRDPF=$P(^LR(LRDFN,0),U,2),Y=+LR(4),SSN=$P(LR(4),"^",2) D SSN^LRU,D^LRU W !,LRP,?31,SSN,?43,Y,?56,$J($P(LR(4),"^",3),2),?59,$P(LR(4),"^",4) D ^LRBLPR1 Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPRA 1934 printed Mar 13, 2025@21:16:21 Page 2
- LRBLPRA ;AVAMC/REG - BB PT RECORD ;2/18/93 09:46 ;
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 IF LR(7)
- IF '$ORDER(^LR(A,1.7,0))
- IF '$ORDER(^LR(A,3,0))
- QUIT
- +4 SET W=^LR(A,0)
- SET Y=$PIECE(W,"^",3)
- SET P=$PIECE(W,"^",2)
- SET X=^DIC(P,0,"GL")
- if '$DATA(@(X_Y_",0)"))
- QUIT
- SET X=^(0)
- SET ^TMP("LRBL",$JOB,P,$PIECE(X,"^"),A)=$PIECE(X,"^",3)_"^"_$PIECE(X,"^",9)_"^"_$PIECE(W,"^",5)_"^"_$PIECE(W,"^",6)
- QUIT
- +5 ;
- EN DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- +1 WRITE !!?20,"PRINT PATIENT BLOOD BANK RECORDS",!!
- +2 WRITE "Print only patients with antibodies/special instructions "
- SET %=1
- SET LR(7)=0
- DO YN^LRU
- if %<1
- GOTO END
- IF %=1
- SET LR(7)=1
- ASK WRITE !!,"Enter the maximum number of specimens to display",!,"in reverse chronological order for each patient: "
- READ LR(8):DTIME
- if LR(8)=""!(LR(8)[U)
- QUIT
- +1 IF LR(8)'?1N.N!(LR(8)<0)!(LR(8)>99)
- WRITE $CHAR(7),!,"ENTER A WHOLE NUMBER FROM 0-99"
- GOTO ASK
- S READ !!,"START WITH PATIENT NAME: FIRST// ",X:DTIME
- if X[U!'$TEST
- GOTO END
- IF X=""
- SET P(1)=0
- SET P(2)="z"
- GOTO T
- +1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
- DO H^LRU
- GOTO S
- +2 SET P(1)=X
- IF $LENGTH(X)>1
- SET X(1)=$ASCII(X,$LENGTH(X))-1
- SET X(1)=$CHAR(X(1))
- SET P(1)=$EXTRACT(X,1,$LENGTH(X)-1)_X(1)
- F READ !,"GO TO PATIENT NAME: LAST// ",X:DTIME
- if X[U!'$TEST
- GOTO END
- IF X=""
- SET P(2)="z"
- GOTO T
- +1 IF X["?"!(X'?1U.E)!($LENGTH(X)>30)
- DO H1^LRU
- GOTO F
- +2 SET P(2)=X
- T SET ZTRTN="QUE^LRBLPRA"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP("LRBL",$JOB)
- DO L^LRU
- DO S^LRU
- +1 FOR A=0:0
- SET A=$ORDER(^LR(A))
- if 'A
- QUIT
- IF $DATA(^(A,1.7))!($DATA(^(3)))!($DATA(^("BB")))
- DO LRBLPRA
- +2 DO H^LRBLPR
- SET LR("F")=1
- +3 FOR LR=0:0
- SET LR=$ORDER(^TMP("LRBL",$JOB,LR))
- if 'LR!(LR("Q"))
- QUIT
- SET LRP=P(1)
- FOR LR(1)=0:0
- SET LRP=$ORDER(^TMP("LRBL",$JOB,LR,LRP))
- if LRP=""!(LRP]P(2))!(LR("Q"))
- QUIT
- DO B
- +4 KILL ^TMP("LRBL",$JOB),^TMP($JOB)
- DO END^LRUTL
- DO END
- QUIT
- +5 ;
- B FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP("LRBL",$JOB,LR,LRP,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- SET LR(4)=^(LRDFN)
- DO W
- +1 QUIT
- W if $Y>(IOSL-6)
- DO H^LRBLPR
- if LR("Q")
- QUIT
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET Y=+LR(4)
- SET SSN=$PIECE(LR(4),"^",2)
- DO SSN^LRU
- DO D^LRU
- WRITE !,LRP,?31,SSN,?43,Y,?56,$JUSTIFY($PIECE(LR(4),"^",3),2),?59,$PIECE(LR(4),"^",4)
- DO ^LRBLPR1
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
