LRAC6 ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89 15:02 ;
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**174,225**;Sep 27, 1994
LRFD1 S LRFD1=0 F S LRFD1=$O(^TMP($J,"K",K,LRFD,LRFD1)) Q:LRFD1<1 S ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,LRFD1)=^TMP($J,"K",K,LRFD,LRFD1)
Q:'$D(^LR(LRDFN,"CH",K(3),0)) S P=$P(^(0),U,9)
S $P(^LR(LRDFN,"CH",K(3),0),U,9)=$S(P[LRMH_":"_LRPG:P,P[":":P_","_LRMH_":"_LRPG,1:LRMH_":"_LRPG)
Q
HEAD1 I 'LRFULL!(LRPERM=1) S LRKL=1
E I 'LRRE S ^LR(LRDFN,"PG",LRMH)=LRMH_U_LRPG S K=0 F S K=$O(^TMP($J,"K",K)) Q:K<1 S LRFD=0 F S LRFD=$O(^TMP($J,"K",K,LRFD)) Q:LRFD<1 S Z=^(LRFD,0),K(2)=$P(Z,U,2),K(3)=$P(Z,U,3),^LAC("LRKILL",LRDFN,LRMH,K,LRFD,0)=Z D LRFD1
K LRFD,K Q
HEAD ;from LRAC3, LRAC4, LRAC5, LRAC7
D LRBOT D TOP Q
TOP ;from LRAC3
W:$G(LRJ02)!($E(IOST,1,2)="C-") @IOF
S LRJ02=1
;W !,PNM,?20,SSN,?33,"AGE: ",AGE
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,PNM,?20,$G(HRCN),?33,"AGE: ",AGE
;----- END IHS MODIFICATIONS
I +LRDPF=2,$L($G(LRWRD)) W ?(IOM-42)," LOC: ",LRWRD
W ?(IOM-22),$S($D(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
;W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG W:LRBOT="T" !
;W !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG ;IHS/OIRM TUC/AAB 1/13/98
W:LRBOT="T" !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9)) ;IHS/OIRM TUC/AAB 1/13/98
;----- END IHS MODIFICATIONS
K ^TMP($J,"K") S LRKL=1,LRAG=0 Q
LRBOT ;from LRAC3
W !
Y I $Y'>(IOSL-6) W ! G Y
;W $E(PNM,1,20),?21,SSN,?(IOM-46),"ROUTING: ",$E(LRLLOC,1,15),?(IOM-26)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W $E(PNM,1,20),?21,$G(HRCN),?(IOM-46),"ROUTING: ",$E(LRLLOC,1,15),?(IOM-26)
;----- END IHS MODIFICATIONS
W $S(LRFULL!(LRPERM):" **PERMANENT**",1:" ")
W " CHART COPY"
;W:LRBOT="B" !
;W $S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W:LRBOT="B" !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9)) ;IHS/OIRM TUC/AAB 1/13/98
;----- END IHS MODIFICATIONS
W:LRBOT'="B" !
W ?(IOM-22),$S($D(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG
S LRTAB=(LRMH-1)*10#80 W !?LRTAB,$E(LRMHN,1,IOM-LRTAB)
S:'$D(LRPG1) LRPG=LRPG+1
Q
LRUDT S LRTIM=$E(LRFDT,9,12) F I=0:0 Q:$L(LRTIM)=4 S LRTIM=LRTIM_0
S LRTIM=$S(LRTIM?4"0":" ",1:$E(LRTIM,1,2)_":"_$E(LRTIM,3,4))
S LRUDT=$E(LRFDT,4,5)_"/"_$E(LRFDT,6,7)_"/"_$E(LRFDT,2,3)_" "_$J(LRTIM,5)_" "
Q
LRKILL D HEAD1,HEAD Q
Q
LRMISC I LRPERM=0 Q:'$D(^LAC("LGOT",LRDFN,"MISC")) S:'$D(LRPG1) LRPG=LRPG+1 K ^TMP($J,"K")
S LRFDT=0 D TOP
MHI S LRMHN=$P(^LAC(LRXLR,LRDFN,LRMH,1,0),U,1),LRCNT=12 D WR
MDT S LRFDT=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT)) G:LRFDT<1 END
I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 D REG^LRAC9
D LRUDT,LRCNT,WR:($Y>(IOSL-LRCNT))
S ^TMP($J,"K",LRFDT,0)=^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,0),LRMIT=0
LRMIT S LRMIT=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT)) G:LRMIT<1 TXT
S ^TMP($J,"K",LRFDT,LRMIT)=$P(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,5)
S LRLO="",LRHI=""
S LRVAL=$P(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,1),LRX19=^(0)
S X1=$P(LRX19,U,4),LRSPE=$P(LRX19,U,2),LRTEST=$P(LRX19,U,3)
S LRSPEM=$S($L(LRSPE):$P(^LAB(61,LRSPE,0),U,1),1:"")
I 'LRTEST W !,"COMMENT: ",LRVAL G LRMIT
S LRUNT="",LRNAME=$P(^LAB(60,LRTEST,.1),U,1),LRPC=$P(^(.1),U,3)
I $L(LRSPE),$D(^LAB(60,LRTEST,1,LRSPE,0)) S @("LRLO="_$S($L($P(^(0),U,2)):$P(^(0),U,2),1:"""""")),@("LRHI="_$S($L($P(^(0),U,3)):$P(^(0),U,3),1:"""""")),LRUNT=$P(^(0),U,7)
WR1 S:'$D(LRCW) LRCW=13 S X=LRVAL
W !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,@$S(LRPC="":"X",1:LRPC)," "
W X1," ",LRUNT,?67 W:$L(LRLO) LRLO,"-",LRHI
I $D(IA) W !,IA K IA,IAX,IARNO,IADA
G LRMIT
WR I $Y>(IOSL-LRCNT) D EQUALS^LRX S LRFULL=1 D ENT^LRAC7,HEAD K ^TMP($J,"K") S LRFULL=0
S LRCL=21-$L(LRMHN) W !!!?LRCL F I=1:1:8 W "* "
F I=1:1:$L(LRMHN) W " ",$E(LRMHN,I)
W " " F I=1:1:8 W " *"
W !!," Date Time Specimen",?37,"Test",?50,"Results"
W ?64,"Ref ranges" D DASH^LRX
Q
TXT S I=0
F S I=$O(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,"TX",I)) Q:'I W !,^(I,0)
G MDT
END D EQUALS^LRX
D LRBOT S LRLO="" K LRSB,LRMISC Q
PRE ;from LRAC3
Q:$O(^LAC(LRXLR,LRDFN,"MISC",1,0))'>0 S LRX21=^(0)
S LRMISC=1
I '$D(LRPG1) S LRPG=$S($L($P(LRX21,U,2))&($G(LRRE)):$P(LRX21,U,2),$D(^LR(LRDFN,"PG",LRMH)):$P(^(LRMH),U,2),1:0)
S LRMH="MISC"
S:'$L($P(^LAC(LRXLR,LRDFN,"MISC",1,0),U,2))!'$G(LRRE) $P(^(0),U,2)=LRPG
G LRMISC
LRCNT S LRCNT=0,I=0
F S I=$O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,1,I)) Q:I<1 S LRCNT=LRCNT+1
S LRCTN=0 I $D(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX")) S J=0 F S J=$O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX",J)) Q:'J S LRCTN=LRCTN+1
S LRCNT=LRCNT*2+5+LRCTN
Q
LRAC6 ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89 15:02 ;
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**174,225**;Sep 27, 1994
LRFD1 SET LRFD1=0
FOR
SET LRFD1=$ORDER(^TMP($JOB,"K",K,LRFD,LRFD1))
IF LRFD1<1
QUIT
SET ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,LRFD1)=^TMP($JOB,"K",K,LRFD,LRFD1)
+1 IF '$DATA(^LR(LRDFN,"CH",K(3),0))
QUIT
SET P=$PIECE(^(0),U,9)
+2 SET $PIECE(^LR(LRDFN,"CH",K(3),0),U,9)=$SELECT(P[LRMH_":"_LRPG:P,P[":":P_","_LRMH_":"_LRPG,1:LRMH_":"_LRPG)
+3 QUIT
HEAD1 IF 'LRFULL!(LRPERM=1)
SET LRKL=1
+1 IF '$TEST
IF 'LRRE
SET ^LR(LRDFN,"PG",LRMH)=LRMH_U_LRPG
SET K=0
FOR
SET K=$ORDER(^TMP($JOB,"K",K))
IF K<1
QUIT
SET LRFD=0
FOR
SET LRFD=$ORDER(^TMP($JOB,"K",K,LRFD))
IF LRFD<1
QUIT
SET Z=^(LRFD,0)
SET K(2)=$PIECE(Z,U,2)
SET K(3)=$PIECE(Z,U,3)
SET ^LAC("LRKILL",LRDFN,LRMH,K,LRFD,0)=Z
DO LRFD1
+2 KILL LRFD,K
QUIT
HEAD ;from LRAC3, LRAC4, LRAC5, LRAC7
+1 DO LRBOT
DO TOP
QUIT
TOP ;from LRAC3
+1 IF $GET(LRJ02)!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET LRJ02=1
+3 ;W !,PNM,?20,SSN,?33,"AGE: ",AGE
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 WRITE !,PNM,?20,$GET(HRCN),?33,"AGE: ",AGE
+6 ;----- END IHS MODIFICATIONS
+7 IF +LRDPF=2
IF $LENGTH($GET(LRWRD))
WRITE ?(IOM-42)," LOC: ",LRWRD
+8 WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
+9 ;W $S($D(LRMISC):"MISC",1:LRMH),":",LRPG W:LRBOT="T" !
+10 ;W !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+12 ;IHS/OIRM TUC/AAB 1/13/98
WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
+13 ;IHS/OIRM TUC/AAB 1/13/98
IF LRBOT="T"
WRITE !,$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))
+14 ;----- END IHS MODIFICATIONS
+15 KILL ^TMP($JOB,"K")
SET LRKL=1
SET LRAG=0
QUIT
LRBOT ;from LRAC3
+1 WRITE !
Y IF $Y'>(IOSL-6)
WRITE !
GOTO Y
+1 ;W $E(PNM,1,20),?21,SSN,?(IOM-46),"ROUTING: ",$E(LRLLOC,1,15),?(IOM-26)
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 WRITE $EXTRACT(PNM,1,20),?21,$GET(HRCN),?(IOM-46),"ROUTING: ",$EXTRACT(LRLLOC,1,15),?(IOM-26)
+4 ;----- END IHS MODIFICATIONS
+5 WRITE $SELECT(LRFULL!(LRPERM):" **PERMANENT**",1:" ")
+6 WRITE " CHART COPY"
+7 ;W:LRBOT="B" !
+8 ;W $S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:$P(^LAB(64.5,1,0),U,9))
+9 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+10 ;IHS/OIRM TUC/AAB 1/13/98
IF LRBOT="B"
WRITE !,$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))
+11 ;----- END IHS MODIFICATIONS
+12 IF LRBOT'="B"
WRITE !
+13 WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
+14 WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
+15 SET LRTAB=(LRMH-1)*10#80
WRITE !?LRTAB,$EXTRACT(LRMHN,1,IOM-LRTAB)
+16 IF '$DATA(LRPG1)
SET LRPG=LRPG+1
+17 QUIT
LRUDT SET LRTIM=$EXTRACT(LRFDT,9,12)
FOR I=0:0
IF $LENGTH(LRTIM)=4
QUIT
SET LRTIM=LRTIM_0
+1 SET LRTIM=$SELECT(LRTIM?4"0":" ",1:$EXTRACT(LRTIM,1,2)_":"_$EXTRACT(LRTIM,3,4))
+2 SET LRUDT=$EXTRACT(LRFDT,4,5)_"/"_$EXTRACT(LRFDT,6,7)_"/"_$EXTRACT(LRFDT,2,3)_" "_$JUSTIFY(LRTIM,5)_" "
+3 QUIT
LRKILL DO HEAD1
DO HEAD
QUIT
+1 QUIT
LRMISC IF LRPERM=0
IF '$DATA(^LAC("LGOT",LRDFN,"MISC"))
QUIT
IF '$DATA(LRPG1)
SET LRPG=LRPG+1
KILL ^TMP($JOB,"K")
+1 SET LRFDT=0
DO TOP
MHI SET LRMHN=$PIECE(^LAC(LRXLR,LRDFN,LRMH,1,0),U,1)
SET LRCNT=12
DO WR
MDT SET LRFDT=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT))
IF LRFDT<1
GOTO END
+1 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
IF LRDPF=2
DO REG^LRAC9
+2 DO LRUDT
DO LRCNT
IF ($Y>(IOSL-LRCNT))
DO WR
+3 SET ^TMP($JOB,"K",LRFDT,0)=^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,0)
SET LRMIT=0
LRMIT SET LRMIT=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT))
IF LRMIT<1
GOTO TXT
+1 SET ^TMP($JOB,"K",LRFDT,LRMIT)=$PIECE(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,5)
+2 SET LRLO=""
SET LRHI=""
+3 SET LRVAL=$PIECE(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,1,LRMIT,0),U,1)
SET LRX19=^(0)
+4 SET X1=$PIECE(LRX19,U,4)
SET LRSPE=$PIECE(LRX19,U,2)
SET LRTEST=$PIECE(LRX19,U,3)
+5 SET LRSPEM=$SELECT($LENGTH(LRSPE):$PIECE(^LAB(61,LRSPE,0),U,1),1:"")
+6 IF 'LRTEST
WRITE !,"COMMENT: ",LRVAL
GOTO LRMIT
+7 SET LRUNT=""
SET LRNAME=$PIECE(^LAB(60,LRTEST,.1),U,1)
SET LRPC=$PIECE(^(.1),U,3)
+8 IF $LENGTH(LRSPE)
IF $DATA(^LAB(60,LRTEST,1,LRSPE,0))
SET @("LRLO="_$SELECT($LENGTH($PIECE(^(0),U,2)):$PIECE(^(0),U,2),1:""""""))
SET @("LRHI="_$SELECT($LENGTH($PIECE(^(0),U,3)):$PIECE(^(0),U,3),1:""""""))
SET LRUNT=$PIECE(^(0),U,7)
WR1 IF '$DATA(LRCW)
SET LRCW=13
SET X=LRVAL
+1 WRITE !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,@$SELECT(LRPC="":"X",1:LRPC)," "
+2 WRITE X1," ",LRUNT,?67
IF $LENGTH(LRLO)
WRITE LRLO,"-",LRHI
+3 IF $DATA(IA)
WRITE !,IA
KILL IA,IAX,IARNO,IADA
+4 GOTO LRMIT
WR IF $Y>(IOSL-LRCNT)
DO EQUALS^LRX
SET LRFULL=1
DO ENT^LRAC7
DO HEAD
KILL ^TMP($JOB,"K")
SET LRFULL=0
+1 SET LRCL=21-$LENGTH(LRMHN)
WRITE !!!?LRCL
FOR I=1:1:8
WRITE "* "
+2 FOR I=1:1:$LENGTH(LRMHN)
WRITE " ",$EXTRACT(LRMHN,I)
+3 WRITE " "
FOR I=1:1:8
WRITE " *"
+4 WRITE !!," Date Time Specimen",?37,"Test",?50,"Results"
+5 WRITE ?64,"Ref ranges"
DO DASH^LRX
+6 QUIT
TXT SET I=0
+1 FOR
SET I=$ORDER(^LAC(LRXLR,LRDFN,"MISC",1,1,LRFDT,"TX",I))
IF 'I
QUIT
WRITE !,^(I,0)
+2 GOTO MDT
END DO EQUALS^LRX
+1 DO LRBOT
SET LRLO=""
KILL LRSB,LRMISC
QUIT
PRE ;from LRAC3
+1 IF $ORDER(^LAC(LRXLR,LRDFN,"MISC",1,0))'>0
QUIT
SET LRX21=^(0)
+2 SET LRMISC=1
+3 IF '$DATA(LRPG1)
SET LRPG=$SELECT($LENGTH($PIECE(LRX21,U,2))&($GET(LRRE)):$PIECE(LRX21,U,2),$DATA(^LR(LRDFN,"PG",LRMH)):$PIECE(^(LRMH),U,2),1:0)
+4 SET LRMH="MISC"
+5 IF '$LENGTH($PIECE(^LAC(LRXLR,LRDFN,"MISC",1,0),U,2))!'$GET(LRRE)
SET $PIECE(^(0),U,2)=LRPG
+6 GOTO LRMISC
LRCNT SET LRCNT=0
SET I=0
+1 FOR
SET I=$ORDER(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,1,I))
IF I<1
QUIT
SET LRCNT=LRCNT+1
+2 SET LRCTN=0
IF $DATA(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX"))
SET J=0
FOR
SET J=$ORDER(^LAC(LRXLR,LRDFN,LRMH,1,1,LRFDT,"TX",J))
IF 'J
QUIT
SET LRCTN=LRCTN+1
+3 SET LRCNT=LRCNT*2+5+LRCTN
+4 QUIT
