LRACSUM6 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY (MISC.) ; 3/9/88 10:23 ; [ 04/11/2003 9:38 AM ]
;;5.2T9;LR;**1006,1008,1018**;Nov 17, 2004
;;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)
;----- BEGIN IHS MODIFCIATIONS LR*5.2*1018
S X=^TMP($J,LRDFN,0) W $P(X,U,1),?20,$P(X,U,2),?33,"DOB: ",$P(X,U,3) ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
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
LRACSUM6 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY (MISC.) ; 3/9/88 10:23 ; [ 04/11/2003 9:38 AM ]
+1 ;;5.2T9;LR;**1006,1008,1018**;Nov 17, 2004
+2 ;;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 ;----- BEGIN IHS MODIFCIATIONS LR*5.2*1018
+4 ;IHS/ANMC/CLS 11/1/95
SET X=^TMP($JOB,LRDFN,0)
WRITE $PIECE(X,U,1),?20,$PIECE(X,U,2),?33,"DOB: ",$PIECE(X,U,3)
+5 ;----- END IHS MODIFICATIONS
+6 IF $PIECE(X,U,4)=2
IF $DATA(^DPT(+$PIECE(X,U,5),.1))
WRITE ?(IOM-42)," LOC: ",^(.1)
+7 ;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:"")
+8 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
