- LRUMDP ;AVAMC/REG - MD SELECTED LAB RESULTS ;3/10/94 09:16 ; [ 04/14/2003 2:15 PM ]
- ;;5.2T9;LR;**1004,1006,1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**3,153**;Sep 27, 1994
- W !!,"New page for each patient " S %=2 D YN^LRU G:%<1 END S:%=1 LRK=1
- S ZTRTN="QUE^LRUMDP" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S Z(2)=$O(^LAB(61,"B","SERUM",0)),Z(3)=$O(^LAB(61,"B","BLOOD",0)),Z(5)=$O(^LAB(61,"B","PLASMA",0))
- D L^LRU,L1^LRU,S^LRU,EN^LRUMD1 D:'$D(LRK) H S P=0,LR("F")=1 I LRDFN(1) D I G OUT
- I LRG]""!(LRE) D EN:LRG]"",EN1:LRE D L G OUT
- F R=0:0 S P=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P)) Q:P=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P,LRDFN)) Q:'LRDFN!(LR("Q")) D I
- OUT W:$E(IOST)="P" @IOF D END^LRUTL,END Q
- I I LRA]"" Q:'$D(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1)) Q:LRA'=^(1)
- J ;
- Q:'$D(^LR(LRDFN,0)) S X=^(0) D
- .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- .;S Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9),LRL=$S($D(@(X_Y_",.1)")):^(.1)_" "_$G(@(X_Y_",.101)")),$D(^LR(LRDFN,.1)):^(.1)_" "_$G(@(X_Y_",.101)")),1:"No Room") D SSN^LRU
- .S (DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9),LRL=$S($D(@(X_Y_",.1)")):^(.1)_" "_$G(@(X_Y_",.101)")),$D(^LR(LRDFN,.1)):^(.1)_" "_$G(@(X_Y_",.101)")),1:"No Room") D SSN^LRU ;IHS/ANMC/CLS 08/18/96
- ;D:$Y>(IOSL-6)!($D(LRK)) H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP S LR=0 F F=0:1 S LR=$O(^TMP($J,"N",LR)) Q:'LR!(LR("Q")) D T
- D:$Y>(IOSL-6)!($D(LRK)) H Q:LR("Q") W !,HRCN,?19,"LOC:",LRL,?44,"Patient: ",LRP S LR=0 F F=0:1 S LR=$O(^TMP($J,"N",LR)) Q:'LR!(LR("Q")) D T ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- Q:LR("Q") W !,LR("%1") Q
- T S LRI=LRLDT,W(1)=0 F S LRI=$O(^LR(LRDFN,"CH",LRI)) Q:'LRI!(LRI>LRSDT)!(LR("Q")) I $P(^(LRI,0),"^",4) F B=0:0 S B=$O(^TMP($J,"L",LR,B)) Q:'B!(LR("Q")) S LRT=^(B) Q:LRT="" I $D(^LR(LRDFN,"CH",LRI,LRT)) D W Q
- Q:LR("Q") W:W(1) !,LR("%") Q
- ;
- W I $Y>(IOSL-6) D H1 Q:LR("Q") S W(1)=W(1)+1
- S W(1)=W(1)+1,X=^LR(LRDFN,"CH",LRI,0),Y=+X_"000",T=$P(X,"^",5),T(1)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$S(Y[".":$E(Y,9,10)_":"_$E(Y,11,12),1:"")
- D:W(1)=1 A W !,T(1) W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?15,$E($P(^LAB(61,T,0),"^"),1,7)
- F X=0:0 S X=$O(^TMP($J,"L",LR,X)) Q:'X S LRT=^(X) I LRT'="",$D(^LR(LRDFN,"CH",LRI,LRT)) S Y=^(LRT) W ?(16+(X*8)),$J($P(Y,"^"),6),$P(Y,"^",2)
- Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"List for: ",$P(^VA(200,DUZ,0),"^") W:LRA]"" ?40,"PT GRP: ",LRA W:LRE ?40,LRE(1) W:IOST'?1"C".E !,"Work copy- DO NOT PUT IN PATIENT'S CHART" W !,LR("%") Q
- H1 ;D H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP Q:W(1)=1
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D H Q:LR("Q") W !,HRCN,?19,"LOC:",LRL,?44,"Patient: ",LRP Q:W(1)=1 ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- A W ! F X=0:0 S X=$O(^TMP($J,"N",LR,X)) Q:'X W ?(16+(X*8)),$J(^TMP($J,"N",LR,X),7)
- Q
- L F R=0:0 S P=$O(^TMP($J,P)) Q:P=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,P,LRDFN)) Q:'LRDFN!(LR("Q")) D:P'="N"&(P'="L") J
- Q
- EN F X=0:0 S X=$O(^DPT("CN",LRG,X)) Q:'X I $D(^DPT(X,"LR")) S Y=^("LR") S:Y ^TMP($J,$P(^DPT(X,0),"^"),Y)=""
- Q
- EN1 F X=LRE(2):0 S X=$O(^SC(LRE,"S",X)) Q:'X!(X\1-LRE(2)) F Y=0:0 S Y=$O(^SC(LRE,"S",X,1,Y)) Q:'Y S Z=+^(Y,0),A=$S($D(^DPT(Z,"LR")):+^("LR"),1:0) S:A ^TMP($J,$P(^DPT(Z,0),"^"),A)=""
- Q
- ;
- END W:$E(IOST)="P" @IOF D V^LRU K LRE,E Q
- LRUMDP ;AVAMC/REG - MD SELECTED LAB RESULTS ;3/10/94 09:16 ; [ 04/14/2003 2:15 PM ]
- +1 ;;5.2T9;LR;**1004,1006,1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**3,153**;Sep 27, 1994
- +3 WRITE !!,"New page for each patient "
- SET %=2
- DO YN^LRU
- IF %<1
- GOTO END
- IF %=1
- SET LRK=1
- +4 SET ZTRTN="QUE^LRUMDP"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET Z(2)=$ORDER(^LAB(61,"B","SERUM",0))
- SET Z(3)=$ORDER(^LAB(61,"B","BLOOD",0))
- SET Z(5)=$ORDER(^LAB(61,"B","PLASMA",0))
- +1 DO L^LRU
- DO L1^LRU
- DO S^LRU
- DO EN^LRUMD1
- IF '$DATA(LRK)
- DO H
- SET P=0
- SET LR("F")=1
- IF LRDFN(1)
- DO I
- GOTO OUT
- +2 IF LRG]""!(LRE)
- IF LRG]""
- DO EN
- IF LRE
- DO EN1
- DO L
- GOTO OUT
- +3 FOR R=0:0
- SET P=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P))
- IF P=""!(LR("Q"))
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P,LRDFN))
- IF 'LRDFN!(LR("Q"))
- QUIT
- DO I
- OUT IF $EXTRACT(IOST)="P"
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- I IF LRA]""
- IF '$DATA(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1))
- QUIT
- IF LRA'=^(1)
- QUIT
- J ;
- +1 IF '$DATA(^LR(LRDFN,0))
- QUIT
- SET X=^(0)
- Begin DoDot:1
- +2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +3 ;S Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9),LRL=$S($D(@(X_Y_",.1)")):^(.1)_" "_$G(@(X_Y_",.101)")),$D(^LR(LRDFN,.1)):^(.1)_" "_$G(@(X_Y_",.101)")),1:"No Room") D SSN^LRU
- +4 ;IHS/ANMC/CLS 08/18/96
- SET (DFN,Y)=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET V=@(X_Y_",0)")
- SET LRP=$PIECE(V,"^")
- SET SSN=$PIECE(V,"^",9)
- SET LRL=$SELECT($DATA(@(X_Y_",.1)")):^(.1)_" "_$GET(@(X_Y_",.101)")),$DATA(^LR(LRDFN,.1)):^(.1)_" "_$GET(@(X_Y_",.101)")),1:"No Room")
- DO SSN^LRU
- End DoDot:1
- +5 ;D:$Y>(IOSL-6)!($D(LRK)) H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP S LR=0 F F=0:1 S LR=$O(^TMP($J,"N",LR)) Q:'LR!(LR("Q")) D T
- +6 ;IHS/ANMC/CLS 08/18/96
- IF $Y>(IOSL-6)!($DATA(LRK))
- DO H
- IF LR("Q")
- QUIT
- WRITE !,HRCN,?19,"LOC:",LRL,?44,"Patient: ",LRP
- SET LR=0
- FOR F=0:1
- SET LR=$ORDER(^TMP($JOB,"N",LR))
- IF 'LR!(LR("Q"))
- QUIT
- DO T
- +7 ;----- END IHS MODIFICATIONS
- +8 IF LR("Q")
- QUIT
- WRITE !,LR("%1")
- QUIT
- T SET LRI=LRLDT
- SET W(1)=0
- FOR
- SET LRI=$ORDER(^LR(LRDFN,"CH",LRI))
- IF 'LRI!(LRI>LRSDT)!(LR("Q"))
- QUIT
- IF $PIECE(^(LRI,0),"^",4)
- FOR B=0:0
- SET B=$ORDER(^TMP($JOB,"L",LR,B))
- IF 'B!(LR("Q"))
- QUIT
- SET LRT=^(B)
- IF LRT=""
- QUIT
- IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
- DO W
- QUIT
- +1 IF LR("Q")
- QUIT
- IF W(1)
- WRITE !,LR("%")
- QUIT
- +2 ;
- W IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- SET W(1)=W(1)+1
- +1 SET W(1)=W(1)+1
- SET X=^LR(LRDFN,"CH",LRI,0)
- SET Y=+X_"000"
- SET T=$PIECE(X,"^",5)
- SET T(1)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$SELECT(Y[".":$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
- +2 IF W(1)=1
- DO A
- WRITE !,T(1)
- IF T'=Z(2)&(T'=Z(3))&(T'=Z(5))
- WRITE ?15,$EXTRACT($PIECE(^LAB(61,T,0),"^"),1,7)
- +3 FOR X=0:0
- SET X=$ORDER(^TMP($JOB,"L",LR,X))
- IF 'X
- QUIT
- SET LRT=^(X)
- IF LRT'=""
- IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
- SET Y=^(LRT)
- WRITE ?(16+(X*8)),$JUSTIFY($PIECE(Y,"^"),6),$PIECE(Y,"^",2)
- +4 QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"List for: ",$PIECE(^VA(200,DUZ,0),"^")
- IF LRA]""
- WRITE ?40,"PT GRP: ",LRA
- IF LRE
- WRITE ?40,LRE(1)
- IF IOST'?1"C".E
- WRITE !,"Work copy- DO NOT PUT IN PATIENT'S CHART"
- WRITE !,LR("%")
- QUIT
- H1 ;D H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP Q:W(1)=1
- +1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +2 ;IHS/ANMC/CLS 08/18/96
- DO H
- IF LR("Q")
- QUIT
- WRITE !,HRCN,?19,"LOC:",LRL,?44,"Patient: ",LRP
- IF W(1)=1
- QUIT
- +3 ;----- END IHS MODIFICATIONS
- A WRITE !
- FOR X=0:0
- SET X=$ORDER(^TMP($JOB,"N",LR,X))
- IF 'X
- QUIT
- WRITE ?(16+(X*8)),$JUSTIFY(^TMP($JOB,"N",LR,X),7)
- +1 QUIT
- L FOR R=0:0
- SET P=$ORDER(^TMP($JOB,P))
- IF P=""!(LR("Q"))
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP($JOB,P,LRDFN))
- IF 'LRDFN!(LR("Q"))
- QUIT
- IF P'="N"&(P'="L")
- DO J
- +1 QUIT
- EN FOR X=0:0
- SET X=$ORDER(^DPT("CN",LRG,X))
- IF 'X
- QUIT
- IF $DATA(^DPT(X,"LR"))
- SET Y=^("LR")
- IF Y
- SET ^TMP($JOB,$PIECE(^DPT(X,0),"^"),Y)=""
- +1 QUIT
- EN1 FOR X=LRE(2):0
- SET X=$ORDER(^SC(LRE,"S",X))
- IF 'X!(X\1-LRE(2))
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(^SC(LRE,"S",X,1,Y))
- IF 'Y
- QUIT
- SET Z=+^(Y,0)
- SET A=$SELECT($DATA(^DPT(Z,"LR")):+^("LR"),1:0)
- IF A
- SET ^TMP($JOB,$PIECE(^DPT(Z,0),"^"),A)=""
- +1 QUIT
- +2 ;
- END IF $EXTRACT(IOST)="P"
- WRITE @IOF
- DO V^LRU
- KILL LRE,E
- QUIT
