LRACSUM6 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY (MISC.) ; 3/9/88 10:23 ;
;;5.2;LAB SERVICE;**47,201,225**;Sep 27, 1994
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))
Y2K1 ;
;Q:$L(LRTIM)'>6
S LRUDT=$$Y2K^LRX($P(LRFDT,"."))_" "_$J(LRTIM,5)_" "
Q
HEAD ;from LRACSUM3, LRACSUM4, LRACSUM5
D LRBOT D TOP Q
LRBOT ;from LRACSUM3
W !
Y I $Y'>(IOSL-6) W ! G Y
W $E($P(^TMP($J,LRDFN,0),U,1),1,20),?21,$P(^(0),U,2),?(IOM-40),"ROUTING: ",LRLLOC W !?10,$S('LRDIS:"** SUMMARY REPORT ** DO NOT FILE **",1:"** DISCHARGE SUMMARY **")
; Y2K
I LRDIS S Y=9999999-LROUT S Y=$$Y2K^LRX(Y) W " From: ",Y," To: " S X1=9999999-$P(LRIN,"."),X2=-1 D C^%DTC S Y=X S Y=$$Y2K^LRX(Y) W Y ; NOIS DES-0495-40180 DRH
W:LRBOT="B" !,$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:"") W:LRBOT'="B" ! W ?(IOM-13)," PAGE: ",$S($D(LRMISC):"MISC",1:LRMH),":",LRPG ;Y2K
S LRTAB=(LRMH-1)*5#80 W !?LRTAB,$E(LRMHN,1,IOM-LRTAB) S LRPG=LRPG+1
Q
TOP ;from LRACSUM3
W @IOF,!
S X=^TMP($J,LRDFN,0) W $P(X,U,1),?20,$P(X,U,2),?33,"AGE: ",$P(X,U,3)
I $P(X,U,4)=2,$D(^DPT(+$P(X,U,5),.1)) W ?(IOM-42)," LOC: ",^(.1)
W ?(IOM-22),LRCDT,?(IOM-12)," PAGE: ",$S($D(LRMISC):"MISC",1:LRMH),":",LRPG W:LRBOT="T" !,"VAMC ",$S($D(^LAB(64.5,1,1,LRMH,0)):$P(^(0),U,2),1:"") ;Y2K
S LRAG=0 Q
KILL D HEAD Q
Q
LRMISC S LRFDT=0,LRPG=1 D TOP
MHI S LRMHN=$P(^TMP($J,LRDFN,LRMH),U,1),LRCNT=12 D WR
MDT S LRFDT=$O(^TMP($J,LRDFN,"MISC",LRFDT)) G:LRFDT<1 END D LRUDT,LRCNT D:$Y>(IOSL-LRCNT) WR S LRMIT=0
LRMIT S LRMIT=$O(^TMP($J,LRDFN,"MISC",LRFDT,LRMIT)) G:LRMIT="TX" TXT G:LRMIT="" MDT S X=^(LRMIT) G:LRMIT=.1 MSG
S LRLO="",LRHI="",LRVAL=$P(X,U,1),LRSPE=$P(X,U,2),LRTEST=$P(X,U,3),X1=$P(X,U,4) S LRSPEM=$S($L(LRSPE):$P(^LAB(61,LRSPE,0),U,1),1:"")
G:'LRTEST COMM S LRUNT="",LRNAME=$P(^LAB(60,LRTEST,.1),U,1) S:$L(LRSPE)&($D(^LAB(60,LRTEST,1,LRSPE,0))) X=^(0),@("LRLO="_$S($L($P(X,U,2)):$P(X,U,2),1:"""""")),@("LRHI="_$S($L($P(X,U,3)):$P(X,U,3),1:"""""")),LRUNT=$P(X,U,7)
WR1 W !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,LRVAL," ",X1," ",LRUNT,?67 W:$L(LRLO) LRLO,"-",LRHI
G LRMIT
MSG W !! X X G LRMIT
COMM W !,"COMMENT: ",LRVAL G LRMIT
WR I $Y>(IOSL-LRCNT) D EQUALS^LRX
I D HEAD
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,"VALUE",?64,"Ref ranges" D DASH^LRX
Q
TXT S I=0 F S I=$O(^TMP($J,LRDFN,"MISC",LRFDT,"TX",I)) Q:'I W !,^(I,0)
G LRMIT
END D EQUALS^LRX
D LRBOT S LRLO="" K LRSB,LRMISC Q
PRE ;from LRACSUM3
Q:$D(^TMP($J,LRDFN,"MISC"))'=11 S LRMISC=1,LRPG=0,LRMH="MISC" G LRMISC
LRCNT S LRCNT=0,I=0 F S I=$O(^TMP($J,LRDFN,LRMH,LRFDT,I)) Q:'I S LRCNT=LRCNT+1
S LRCTN=0 I $D(^(LRFDT,"TX")) S J=0 F S J=$O(^TMP($J,LRDFN,LRMH,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[HLRACSUM6 2911 printed Sep 23, 2025@19:42:19 Page 2
LRACSUM6 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY (MISC.) ; 3/9/88 10:23 ;
+1 ;;5.2;LAB SERVICE;**47,201,225**;Sep 27, 1994
LRUDT SET LRTIM=$EXTRACT(LRFDT,9,12)
FOR I=0:0
if $LENGTH(LRTIM)=4
QUIT
SET LRTIM=LRTIM_0
+1 ;
+2 SET LRTIM=$SELECT(LRTIM?4"0":" ",1:$EXTRACT(LRTIM,1,2)_":"_$EXTRACT(LRTIM,3,4))
Y2K1 ;
+1 ;Q:$L(LRTIM)'>6
+2 SET LRUDT=$$Y2K^LRX($PIECE(LRFDT,"."))_" "_$JUSTIFY(LRTIM,5)_" "
+3 QUIT
HEAD ;from LRACSUM3, LRACSUM4, LRACSUM5
+1 DO LRBOT
DO TOP
QUIT
LRBOT ;from LRACSUM3
+1 WRITE !
Y IF $Y'>(IOSL-6)
WRITE !
GOTO Y
+1 WRITE $EXTRACT($PIECE(^TMP($JOB,LRDFN,0),U,1),1,20),?21,$PIECE(^(0),U,2),?(IOM-40),"ROUTING: ",LRLLOC
WRITE !?10,$SELECT('LRDIS:"** SUMMARY REPORT ** DO NOT FILE **",1:"** DISCHARGE SUMMARY **")
+2 ; Y2K
+3 ; NOIS DES-0495-40180 DRH
IF LRDIS
SET Y=9999999-LROUT
SET Y=$$Y2K^LRX(Y)
WRITE " From: ",Y," To: "
SET X1=9999999-$PIECE(LRIN,".")
SET X2=-1
DO C^%DTC
SET Y=X
SET Y=$$Y2K^LRX(Y)
WRITE Y
+4 ;Y2K
if LRBOT="B"
WRITE !,$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:"")
if LRBOT'="B"
WRITE !
WRITE ?(IOM-13)," PAGE: ",$SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
+5 SET LRTAB=(LRMH-1)*5#80
WRITE !?LRTAB,$EXTRACT(LRMHN,1,IOM-LRTAB)
SET LRPG=LRPG+1
+6 QUIT
TOP ;from LRACSUM3
+1 WRITE @IOF,!
+2 SET X=^TMP($JOB,LRDFN,0)
WRITE $PIECE(X,U,1),?20,$PIECE(X,U,2),?33,"AGE: ",$PIECE(X,U,3)
+3 IF $PIECE(X,U,4)=2
IF $DATA(^DPT(+$PIECE(X,U,5),.1))
WRITE ?(IOM-42)," LOC: ",^(.1)
+4 ;Y2K
WRITE ?(IOM-22),LRCDT,?(IOM-12)," PAGE: ",$SELECT($DATA(LRMISC):"MISC",1:LRMH),":",LRPG
if LRBOT="T"
WRITE !,"VAMC ",$SELECT($DATA(^LAB(64.5,1,1,LRMH,0)):$PIECE(^(0),U,2),1:"")
+5 SET LRAG=0
QUIT
KILL DO HEAD
QUIT
+1 QUIT
LRMISC SET LRFDT=0
SET LRPG=1
DO TOP
MHI SET LRMHN=$PIECE(^TMP($JOB,LRDFN,LRMH),U,1)
SET LRCNT=12
DO WR
MDT SET LRFDT=$ORDER(^TMP($JOB,LRDFN,"MISC",LRFDT))
if LRFDT<1
GOTO END
DO LRUDT
DO LRCNT
if $Y>(IOSL-LRCNT)
DO WR
SET LRMIT=0
LRMIT SET LRMIT=$ORDER(^TMP($JOB,LRDFN,"MISC",LRFDT,LRMIT))
if LRMIT="TX"
GOTO TXT
if LRMIT=""
GOTO MDT
SET X=^(LRMIT)
if LRMIT=.1
GOTO MSG
+1 SET LRLO=""
SET LRHI=""
SET LRVAL=$PIECE(X,U,1)
SET LRSPE=$PIECE(X,U,2)
SET LRTEST=$PIECE(X,U,3)
SET X1=$PIECE(X,U,4)
SET LRSPEM=$SELECT($LENGTH(LRSPE):$PIECE(^LAB(61,LRSPE,0),U,1),1:"")
+2 if 'LRTEST
GOTO COMM
SET LRUNT=""
SET LRNAME=$PIECE(^LAB(60,LRTEST,.1),U,1)
if $LENGTH(LRSPE)&($DATA(^LAB(60,LRTEST,1,LRSPE,0)))
SET X=^(0)
SET @("LRLO="_$SELECT($LENGTH($PIECE(X,U,2)):$PIECE(X,U,2),1:""""""))
SET @("LRHI="_$SELECT($LENGTH($PIECE(X,U,3)):$PIECE(X,U,3),1:""""""))
SET LRUNT=$PIECE(X,U,7)
WR1 WRITE !!,LRUDT,?15,LRSPEM,?36,LRNAME,":",?50,LRVAL," ",X1," ",LRUNT,?67
if $LENGTH(LRLO)
WRITE LRLO,"-",LRHI
+1 GOTO LRMIT
MSG WRITE !!
XECUTE X
GOTO LRMIT
COMM WRITE !,"COMMENT: ",LRVAL
GOTO LRMIT
WR IF $Y>(IOSL-LRCNT)
DO EQUALS^LRX
+1 IF $TEST
DO HEAD
+2 SET LRCL=21-$LENGTH(LRMHN)
WRITE !!!?LRCL
FOR I=1:1:8
WRITE "* "
+3 FOR I=1:1:$LENGTH(LRMHN)
WRITE " ",$EXTRACT(LRMHN,I)
+4 WRITE " "
FOR I=1:1:8
WRITE " *"
+5 WRITE !!," DATE TIME SPECIMEN",?37,"TEST",?50,"VALUE",?64,"Ref ranges"
DO DASH^LRX
+6 QUIT
TXT SET I=0
FOR
SET I=$ORDER(^TMP($JOB,LRDFN,"MISC",LRFDT,"TX",I))
if 'I
QUIT
WRITE !,^(I,0)
+1 GOTO LRMIT
END DO EQUALS^LRX
+1 DO LRBOT
SET LRLO=""
KILL LRSB,LRMISC
QUIT
PRE ;from LRACSUM3
+1 if $DATA(^TMP($JOB,LRDFN,"MISC"))'=11
QUIT
SET LRMISC=1
SET LRPG=0
SET LRMH="MISC"
GOTO LRMISC
LRCNT SET LRCNT=0
SET I=0
FOR
SET I=$ORDER(^TMP($JOB,LRDFN,LRMH,LRFDT,I))
if 'I
QUIT
SET LRCNT=LRCNT+1
+1 SET LRCTN=0
IF $DATA(^(LRFDT,"TX"))
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,LRDFN,LRMH,LRFDT,"TX",J))
if 'J
QUIT
SET LRCTN=LRCTN+1
+2 SET LRCNT=LRCNT*2+5+LRCTN
+3 QUIT
