- LRAC5 ;SLC/DCM - PRINT CUMULATIVE REPORT ; 12/23/87 11:13 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- TS2 S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2) Q:(IOM-LRCL)<LRCW S LRCL=LRCL+LRCW,A=$L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,7))\2,B=LRCW\2 W $J($P(^(I(I)),U,7),(A+B)),?LRCL S LRFALT=0
- Q
- TS1 F I=J:1:LRJS I $D(I(I)) S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2),LRCL=LRCL+LRCW D LRLO^LRAC9 S A=$L(LRLOHI)\2,B=LRCW\2 W $J(LRLOHI,(A+B)),?LRCL
- Q
- TS ;from LRAC3
- I LRACT'=0 D EQUALS^LRX
- K I S I=0,LRII=0 F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 S I=I+1,I(I)=LRII
- S LRFALT=0,LRCTR=0,LRACT=LRACT+1,J=LRJS+1,LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20)
- I J'>LRSHD W !! W:$D(LRCALE(LRMH,LRSH)) "Locale " W LRTOPP,?LRCL
- F I=J:1:LRSHD I $D(I(I)) S Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),LRCW=$P(Z,U,2) Q:(IOM-LRCL)<LRCW S LRCL=LRCL+LRCW,A=$L($P(Z,U,3))\2,B=LRCW\2 W $J($E($P(Z,U,3),1,(LRCW-1)),(A+B)),?LRCL
- S LRJS=(I-1) S:LRACT=LRPL LRJS=LRJS+1
- F I=J:1:LRJS I $D(I(I)) Q:'$D(^LAB(64.5,"A",1,LRMH,LRSH,I(I))) S Z=^(I(I)) S:$L($P(Z,U,2))!$L($P(Z,U,11)) LRFALT=1
- S LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20)
- I LRFALT W ! W:$D(LRCALE(LRMH,LRSH)) ?8 W $S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(J)),U,11)):"Therapeutic",1:"Ref range"),?LRCL D TS1
- F I=J:1:LRJS I $D(I(I)) Q:'$D(^LAB(64.5,"A",1,LRMH,LRSH,I(I))) S:$L($P(^(I(I)),U,7)) LRFALT=1
- I LRFALT S LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20) W !?LRCL F I=J:1:LRJS I $D(I(I)) D TS2
- S LRFALT=0 D DASH^LRX
- LRFDT K A,B S:LRNP LRFFDT=LRFDT,LRNP=0 S LRFDT=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT)) G:LRFDT<1 LOOP^LRAC3 S Z1=^(LRFDT,0)
- S LRTLOC=$P(Z1,U,2),^TMP($J,"K",LRSH,LRFDT,0)=LRSH_U_$P(Z1,U,1)_U_$P(Z1,U,5) S:LRFDT>LRLFDT LRLFDT=LRFDT
- I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 D REG^LRAC9
- GOUT D QRS^LRAC9 I LRCTR>LRLNS&(LRACT'<LRPL) S LRFULL=1 D TXT1^LRAC9 G:$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRLFDT))<1 LRSH^LRAC3 D HEAD1^LRAC6,HEAD^LRAC6,LRLNS^LRAC3 S LRFULL=0,LRFDT=LRLFDT G TS
- I LRCTR>LRLNS&(LRACT<LRPL) S LRFDT=LRFFDT G TS
- G LRFDT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC5 2042 printed Feb 18, 2025@23:32:03 Page 2
- LRAC5 ;SLC/DCM - PRINT CUMULATIVE REPORT ; 12/23/87 11:13 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- TS2 SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
- if (IOM-LRCL)<LRCW
- QUIT
- SET LRCL=LRCL+LRCW
- SET A=$LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,7))\2
- SET B=LRCW\2
- WRITE $JUSTIFY($PIECE(^(I(I)),U,7),(A+B)),?LRCL
- SET LRFALT=0
- +1 QUIT
- TS1 FOR I=J:1:LRJS
- IF $DATA(I(I))
- SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
- SET LRCL=LRCL+LRCW
- DO LRLO^LRAC9
- SET A=$LENGTH(LRLOHI)\2
- SET B=LRCW\2
- WRITE $JUSTIFY(LRLOHI,(A+B)),?LRCL
- +1 QUIT
- TS ;from LRAC3
- +1 IF LRACT'=0
- DO EQUALS^LRX
- +2 KILL I
- SET I=0
- SET LRII=0
- FOR
- SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
- if LRII<1
- QUIT
- SET I=I+1
- SET I(I)=LRII
- +3 SET LRFALT=0
- SET LRCTR=0
- SET LRACT=LRACT+1
- SET J=LRJS+1
- SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- +4 IF J'>LRSHD
- WRITE !!
- if $DATA(LRCALE(LRMH,LRSH))
- WRITE "Locale "
- WRITE LRTOPP,?LRCL
- +5 FOR I=J:1:LRSHD
- IF $DATA(I(I))
- SET Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
- SET LRCW=$PIECE(Z,U,2)
- if (IOM-LRCL)<LRCW
- QUIT
- SET LRCL=LRCL+LRCW
- SET A=$LENGTH($PIECE(Z,U,3))\2
- SET B=LRCW\2
- WRITE $JUSTIFY($EXTRACT($PIECE(Z,U,3),1,(LRCW-1)),(A+B)),?LRCL
- +6 SET LRJS=(I-1)
- if LRACT=LRPL
- SET LRJS=LRJS+1
- +7 FOR I=J:1:LRJS
- IF $DATA(I(I))
- if '$DATA(^LAB(64.5,"A",1,LRMH,LRSH,I(I)))
- QUIT
- SET Z=^(I(I))
- if $LENGTH($PIECE(Z,U,2))!$LENGTH($PIECE(Z,U,11))
- SET LRFALT=1
- +8 SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- +9 IF LRFALT
- WRITE !
- if $DATA(LRCALE(LRMH,LRSH))
- WRITE ?8
- WRITE $SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(J)),U,11)):"Therapeutic",1:"Ref range"),?LRCL
- DO TS1
- +10 FOR I=J:1:LRJS
- IF $DATA(I(I))
- if '$DATA(^LAB(64.5,"A",1,LRMH,LRSH,I(I)))
- QUIT
- if $LENGTH($PIECE(^(I(I)),U,7))
- SET LRFALT=1
- +11 IF LRFALT
- SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- WRITE !?LRCL
- FOR I=J:1:LRJS
- IF $DATA(I(I))
- DO TS2
- +12 SET LRFALT=0
- DO DASH^LRX
- LRFDT KILL A,B
- if LRNP
- SET LRFFDT=LRFDT
- SET LRNP=0
- SET LRFDT=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT))
- if LRFDT<1
- GOTO LOOP^LRAC3
- SET Z1=^(LRFDT,0)
- +1 SET LRTLOC=$PIECE(Z1,U,2)
- SET ^TMP($JOB,"K",LRSH,LRFDT,0)=LRSH_U_$PIECE(Z1,U,1)_U_$PIECE(Z1,U,5)
- if LRFDT>LRLFDT
- SET LRLFDT=LRFDT
- +2 IF $DATA(DUZ("AG"))
- IF $LENGTH(DUZ("AG"))
- IF "ARMYAFN"[DUZ("AG")
- IF LRDPF=2
- DO REG^LRAC9
- GOUT DO QRS^LRAC9
- IF LRCTR>LRLNS&(LRACT'<LRPL)
- SET LRFULL=1
- DO TXT1^LRAC9
- if $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRLFDT))<1
- GOTO LRSH^LRAC3
- DO HEAD1^LRAC6
- DO HEAD^LRAC6
- DO LRLNS^LRAC3
- SET LRFULL=0
- SET LRFDT=LRLFDT
- GOTO TS
- +1 IF LRCTR>LRLNS&(LRACT<LRPL)
- SET LRFDT=LRFFDT
- GOTO TS
- +2 GOTO LRFDT
