LRAC9 ;VA/SLC/DCM - PRINT CUMULATIVE REPORT ;JUL 06, 2010 3:14 PM;
;;5.2;LAB SERVICE;**225,1018,1027**;NOV 01, 1997
C S ^TMP($J,"K",LRSH,LRFDT,LRKL)=$P(X,U,3),X1=" "_$P(X,U,2),X=$P(X,U,1),LRKL=LRKL+1
I $L($P(LRG,U,4)) S LRCW=LRCW-3 Q
I "<>"[$E(X,1),$E(X,2,$L(X))?.N.P1N S X2=$E(X,1),X=$E(X,2,$L(X))
S LRCW(1)=LRCW-3
I X?.N.P1N!(LRDP="")!(X?.N1".".N) S X=$S(LRDP="":$J(X,LRCW(1)),1:$J(X,LRCW(1),LRDP)) Q:'$D(X2) F X3=1:1:$L(X) I $E(X,X3)'=" " S X=$E(X,1,X3-2)_X2_$E(X,X3,$L(X)) Q
K X3 Q
C1 ;from LRAC4
S LRCW=$S('$L(X1):7,1:10),X1=$S($L(X1)=1:" "_X1_" ",$L(X1)=0:X1,1:" "_X1)
I $L($P(LRG,U,4)) S LRCW=7 Q
S X=$S($L(X1):X_X1,1:X)
Q
QRS1 W ?LRCL S LRCW=$P(LRG,U,2),LRDP=$P(^(0),U,6) Q:(IOM-LRCL)<LRCW
S LRCL=LRCL+LRCW I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0)) S X=^(0) D C W:$L($P(LRG,U,4))&($L(X)) @$P(LRG,U,4),X1 I '$L($P(LRG,U,4)) W X_X1
K X2 Q
QRS ;from LRAC5
; S LRCTR=LRCTR+1 F I=J:1:LRJS I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0)) S:$L(^(0)) LRFALT=1
S LRCTR=LRCTR+1 F I=J:1:LRJS I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,+$G(I(I)),0)) S:$L(^(0)) LRFALT=1 ; IHS/OIT/MKK - LR*5.2*1027
Q:'LRFALT
S LRFALT=0,LRTM=1 D UDT^LRAC3 S LRCL=$S($D(LRCALE(LRMH,LRSH)):23,1:19),LRTM=0 W ! W:$D(LRCALE(LRMH,LRSH)) $E(LRTLOC,1,5) W:LRNXSW&($D(LRCALE(LRMH,LRSH))) ?6 W:'LRNXSW&('$D(LRCALE(LRMH,LRSH))) ?2 W:'LRNXSW&($D(LRCALE(LRMH,LRSH))) ?8 W LRUDT
; F I=J:1:LRJS S LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0) D QRS1
F I=J:1:LRJS S LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,+$G(I(I)),0) D QRS1 ; IHS/OIT/MKK - LR*5.2*1027
I $D(IA) W !?2,IA,! K IA,IAX,IADA,IARNO
Q
TXT1 ;from LRAC3, LRAC4, LRAC5
D EQUALS^LRX
S LRCL=(IOM/2)-24 W !!?LRCL F I=1:1:8 W "- "
F I=1:1:8 W " ",$E("COMMENTS",I)
W " " F I=1:1:8 W " -"
W !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value",!
Q:'$D(LRTM(0)) S C6=0 F S C6=$O(^TMP($J,"TM",C6)) Q:C6="" D:$Y>(IOSL-8) OVFL^LRAC7 W !," ",$P(^TMP($J,"TM",C6),U,1),". " S L(0)=0,L=0 F S L=$O(^TMP($J,"TM",C6,L)) Q:'L S L(0)=L(0)+1 W:L(0)>1 !," " W ^TMP($J,"TM",C6,L)
K C6,L Q
LRLO ;from LRAC4, LRAC5
S @("LRLO="_$S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,2)):$P(^(I(I)),U,2),$L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,11)):$P(^(I(I)),U,11),1:""""""))
LRHI S @("LRHI="_$S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,3)):$P(^(I(I)),U,3),$L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,12)):$P(^(I(I)),U,12),1:"""""")),P7=$P(^(I(I)),U,7)
S LRLOHI=$S($L(LRHI):LRLO_"-"_LRHI_" ",1:LRLO) Q
TXT ;from LRAC4
S LRVAR=0
S LRIV=0 F S LRIV=$O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIV)) Q:'LRIV S LRVAR=LRVAR+1 W:LRVAR>1 !?3 W ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIV,0)
Q
REG ;from LRAC5, LRAC6, LRMIPSZ1
;This line tag is used by DoD sites only
Q:'$L(DUZ("AG")) I "NAFARMY"'[DUZ("AG") Q
S IADA=$P(^LR(LRDFN,0),U,3) I IADA'="",$D(^DPT(IADA,0)) S IAX=LRFDT D ^LRAIRNUM I IARNO'="" S IA="INPAT REG # "_IARNO
Q
LRAC9 ;VA/SLC/DCM - PRINT CUMULATIVE REPORT ;JUL 06, 2010 3:14 PM;
+1 ;;5.2;LAB SERVICE;**225,1018,1027**;NOV 01, 1997
C SET ^TMP($JOB,"K",LRSH,LRFDT,LRKL)=$PIECE(X,U,3)
SET X1=" "_$PIECE(X,U,2)
SET X=$PIECE(X,U,1)
SET LRKL=LRKL+1
+1 IF $LENGTH($PIECE(LRG,U,4))
SET LRCW=LRCW-3
QUIT
+2 IF "<>"[$EXTRACT(X,1)
IF $EXTRACT(X,2,$LENGTH(X))?.N.P1N
SET X2=$EXTRACT(X,1)
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 SET LRCW(1)=LRCW-3
+4 IF X?.N.P1N!(LRDP="")!(X?.N1".".N)
SET X=$SELECT(LRDP="":$JUSTIFY(X,LRCW(1)),1:$JUSTIFY(X,LRCW(1),LRDP))
IF '$DATA(X2)
QUIT
FOR X3=1:1:$LENGTH(X)
IF $EXTRACT(X,X3)'=" "
SET X=$EXTRACT(X,1,X3-2)_X2_$EXTRACT(X,X3,$LENGTH(X))
QUIT
+5 KILL X3
QUIT
C1 ;from LRAC4
+1 SET LRCW=$SELECT('$LENGTH(X1):7,1:10)
SET X1=$SELECT($LENGTH(X1)=1:" "_X1_" ",$LENGTH(X1)=0:X1,1:" "_X1)
+2 IF $LENGTH($PIECE(LRG,U,4))
SET LRCW=7
QUIT
+3 SET X=$SELECT($LENGTH(X1):X_X1,1:X)
+4 QUIT
QRS1 WRITE ?LRCL
SET LRCW=$PIECE(LRG,U,2)
SET LRDP=$PIECE(^(0),U,6)
IF (IOM-LRCL)<LRCW
QUIT
+1 SET LRCL=LRCL+LRCW
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0))
SET X=^(0)
DO C
IF $LENGTH($PIECE(LRG,U,4))&($LENGTH(X))
WRITE @$PIECE(LRG,U,4),X1
IF '$LENGTH($PIECE(LRG,U,4))
WRITE X_X1
+2 KILL X2
QUIT
QRS ;from LRAC5
+1 ; S LRCTR=LRCTR+1 F I=J:1:LRJS I $D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,I(I),0)) S:$L(^(0)) LRFALT=1
+2 ; IHS/OIT/MKK - LR*5.2*1027
SET LRCTR=LRCTR+1
FOR I=J:1:LRJS
IF $DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,1,+$GET(I(I)),0))
IF $LENGTH(^(0))
SET LRFALT=1
+3 IF 'LRFALT
QUIT
+4 SET LRFALT=0
SET LRTM=1
DO UDT^LRAC3
SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):23,1:19)
SET LRTM=0
WRITE !
IF $DATA(LRCALE(LRMH,LRSH))
WRITE $EXTRACT(LRTLOC,1,5)
IF LRNXSW&($DATA(LRCALE(LRMH,LRSH)))
WRITE ?6
IF 'LRNXSW&('$DATA(LRCALE(LRMH,LRSH)))
WRITE ?2
IF 'LRNXSW&($DATA(LRCALE(LRMH,LRSH)))
WRITE ?8
WRITE LRUDT
+5 ; F I=J:1:LRJS S LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0) D QRS1
+6 ; IHS/OIT/MKK - LR*5.2*1027
FOR I=J:1:LRJS
SET LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,+$GET(I(I)),0)
DO QRS1
+7 IF $DATA(IA)
WRITE !?2,IA,!
KILL IA,IAX,IADA,IARNO
+8 QUIT
TXT1 ;from LRAC3, LRAC4, LRAC5
+1 DO EQUALS^LRX
+2 SET LRCL=(IOM/2)-24
WRITE !!?LRCL
FOR I=1:1:8
WRITE "- "
+3 FOR I=1:1:8
WRITE " ",$EXTRACT("COMMENTS",I)
+4 WRITE " "
FOR I=1:1:8
WRITE " -"
+5 WRITE !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value",!
+6 IF '$DATA(LRTM(0))
QUIT
SET C6=0
FOR
SET C6=$ORDER(^TMP($JOB,"TM",C6))
IF C6=""
QUIT
IF $Y>(IOSL-8)
DO OVFL^LRAC7
WRITE !," ",$PIECE(^TMP($JOB,"TM",C6),U,1),". "
SET L(0)=0
SET L=0
FOR
SET L=$ORDER(^TMP($JOB,"TM",C6,L))
IF 'L
QUIT
SET L(0)=L(0)+1
IF L(0)>1
WRITE !," "
WRITE ^TMP($JOB,"TM",C6,L)
+7 KILL C6,L
QUIT
LRLO ;from LRAC4, LRAC5
+1 SET @("LRLO="_$SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,2)):$PIECE(^(I(I)),U,2),$LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,11)):$PIECE(^(I(I)),U,11),1:""""""))
LRHI SET @("LRHI="_$SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,3)):$PIECE(^(I(I)),U,3),$LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,12)):$PIECE(^(I(I)),U,12),1:""""""))
SET P7=$PIECE(^(I(I)),U,7)
+1 SET LRLOHI=$SELECT($LENGTH(LRHI):LRLO_"-"_LRHI_" ",1:LRLO)
QUIT
TXT ;from LRAC4
+1 SET LRVAR=0
+2 SET LRIV=0
FOR
SET LRIV=$ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIV))
IF 'LRIV
QUIT
SET LRVAR=LRVAR+1
IF LRVAR>1
WRITE !?3
WRITE ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRFDT,"TX",LRIV,0)
+3 QUIT
REG ;from LRAC5, LRAC6, LRMIPSZ1
+1 ;This line tag is used by DoD sites only
+2 IF '$LENGTH(DUZ("AG"))
QUIT
IF "NAFARMY"'[DUZ("AG")
QUIT
+3 SET IADA=$PIECE(^LR(LRDFN,0),U,3)
IF IADA'=""
IF $DATA(^DPT(IADA,0))
SET IAX=LRFDT
DO ^LRAIRNUM
IF IARNO'=""
SET IA="INPAT REG # "_IARNO
+4 QUIT
