- LRAC6 ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89 15:02 ;
- ;;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
- 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))
- 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)
- 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))
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC6 4149 printed Feb 18, 2025@23:32:04 Page 2
- LRAC6 ;SLC/DCM/MIWL/JMC - PRINT CUMULATIVE REPORT CONT. (MISC.) ; 1/31/89 15:02 ;
- +1 ;;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 WRITE !,PNM,?20,SSN,?33,"AGE: ",AGE
- +4 IF +LRDPF=2
- IF $LENGTH($GET(LRWRD))
- WRITE ?(IOM-42)," LOC: ",LRWRD
- +5 WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
- +6 WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
- if LRBOT="T"
- WRITE !
- +7 WRITE !,$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))
- +8 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 WRITE $EXTRACT(PNM,1,20),?21,SSN,?(IOM-46),"ROUTING: ",$EXTRACT(LRLLOC,1,15),?(IOM-26)
- +2 WRITE $SELECT(LRFULL!(LRPERM):" **PERMANENT**",1:" ")
- +3 WRITE " CHART COPY"
- +4 if LRBOT="B"
- WRITE !
- +5 WRITE $SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:$PIECE(^LAB(64.5,1,0),U,9))
- +6 if LRBOT'="B"
- WRITE !
- +7 WRITE ?(IOM-22),$SELECT($DATA(LRCDT):LRCDT,1:"??"),?(IOM-13),"PAGE: "
- +8 WRITE $SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
- +9 SET LRTAB=(LRMH-1)*10#80
- WRITE !?LRTAB,$EXTRACT(LRMHN,1,IOM-LRTAB)
- +10 if '$DATA(LRPG1)
- SET LRPG=LRPG+1
- +11 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