- 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
