- LRACSUM3 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY ; 3/3/88 13:30 ;
- ;;5.2;LAB SERVICE;**201,225**;Sep 27, 1994
- S LRAG=0,LRYESCOM=0,LRIL=0,LRFULL=0
- D LRMH S LRMH="MISC" G PRE^LRACSUM6
- LRMH S LRMH=0 F S LRMH=$O(^TMP($J,LRDFN,LRMH)) Q:LRMH<1 S X=^(LRMH) D MH1
- Q
- MH1 S LRMHN=$P(X,U,1),LRSH=0
- S LRPG=1
- D TOP^LRACSUM6
- S LROFMT="",LRFDE=0 D LRSH D:'LRFDE LRBOT^LRACSUM6 K LRTM,^TMP($J,"TM") S LRFULL=0,LRTM=0,LROFMT="",LRFDE=0
- Q
- LRSH ;from LRACSUM4, LRACSUM5
- S LRSH=$O(^TMP($J,LRDFN,LRMH,LRSH)) Q:LRSH<1 G:$D(^(LRSH))'=11 LRSH S X=^(LRSH),LRSHN=$P(X,U,1),LRTOPP=$P(X,U,2),LRSHD=$P(X,U,3),LRFMT=$P(X,U,4),LRFMT(1)=$E(LRFMT,1),LROFMT(1)=$E(LROFMT,1)
- I (LROFMT["V"&(LRFMT["V"))!(LROFMT'=""&(LRFMT(1)'=LROFMT(1))) S LROFMT="" D HEAD^LRACSUM6
- S LROFMT=LRFMT,LRTOPP=$E($P(^LAB(61,LRTOPP,0),U,1),1,13),LRTOT=0,LRPL=1,LRACT=0,LRJS=0,LRTS=0,LRFDE=0
- S LRNP=0,LRFDT=0,LRLFDT=0,LRFFDT=0 D LRNP
- LOOP ;from LRACSUM5
- I LRACT<LRPL S LRFDT=LRFFDT G:LRFMT["H" TS^LRACSUM5 I LRFMT["V" S LRMULT=1,LRMU=0 D MUL G BS^LRACSUM4
- D TXT1^LRACSUM5 I LRCTR'<LRLNS!(IOSL-18<$Y) S LRFULL=1 S:'LRFDT LRFED=1 D:LRFDE LRBOT^LRACSUM6 D:'LRFDT HEAD^LRACSUM6 S LRFULL=0 G LRSH
- G LRSH
- LRNP ;from LRACSUM4
- S I=0 F S I=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,I)) Q:I<1 S LRTOT=LRTOT+$P(^(I,0),U,2) I LRTOT>(IOM-20) S LRPL=LRPL+1,LRTOT=$P(^(0),U,2)
- LRLNS ;from LRACSUM5
- K LRTM,^TMP($J,"TM") S LRTM=0
- S LRLNS=((IOSL-18)-($Y+(6*LRPL)))\LRPL
- S LRCL=(IOM/2)-(5+($L(LRSHN)/2)) W !!?LRCL,"---- ",LRSHN," ----"
- S LRACT=0,LRJS=0,LRNP=1
- Q
- UDT ;from LRACSUM4, LRACSUM5
- S LRBDT=LRFDT,LRFDT=$S($P(^LAB(64.5,1,1,LRMH,1,LRSH,0),U,3)["I":$P(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,0),U,2),1:LRFDT),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))
- S LRUDT=$E($$Y2K^LRX($P(LRFDT,".")),1,5)_" "_$J(LRTIM,4)_" " S LRFDT=LRBDT D:LRTM LRTM
- Q
- LRTM S LRNXSW=0 S:'$D(LRTM(0)) LRTM(0)=96
- I $D(^TMP($J,"TM",LRFDT)) S LRNXSW=1
- E I $D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX")) S LRTM(0)=LRTM(0)+1,LRNX=$C(LRTM(0)),^TMP($J,"TM",LRFDT)=LRNX,LRNXSW=1 S I=0 F S I=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX",I)) Q:'I S ^TMP($J,"TM",LRFDT,I)=^(I,0)
- ;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT
- D Y2KALT^LRAC3
- Q
- MUL F I=0:0 Q:LRMULT*(LRSHD+15)>(IOSL-9) S LRMULT=LRMULT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACSUM3 2330 printed Feb 18, 2025@23:32:30 Page 2
- LRACSUM3 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY ; 3/3/88 13:30 ;
- +1 ;;5.2;LAB SERVICE;**201,225**;Sep 27, 1994
- +2 SET LRAG=0
- SET LRYESCOM=0
- SET LRIL=0
- SET LRFULL=0
- +3 DO LRMH
- SET LRMH="MISC"
- GOTO PRE^LRACSUM6
- LRMH SET LRMH=0
- FOR
- SET LRMH=$ORDER(^TMP($JOB,LRDFN,LRMH))
- if LRMH<1
- QUIT
- SET X=^(LRMH)
- DO MH1
- +1 QUIT
- MH1 SET LRMHN=$PIECE(X,U,1)
- SET LRSH=0
- +1 SET LRPG=1
- +2 DO TOP^LRACSUM6
- +3 SET LROFMT=""
- SET LRFDE=0
- DO LRSH
- if 'LRFDE
- DO LRBOT^LRACSUM6
- KILL LRTM,^TMP($JOB,"TM")
- SET LRFULL=0
- SET LRTM=0
- SET LROFMT=""
- SET LRFDE=0
- +4 QUIT
- LRSH ;from LRACSUM4, LRACSUM5
- +1 SET LRSH=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH))
- if LRSH<1
- QUIT
- if $DATA(^(LRSH))'=11
- GOTO LRSH
- SET X=^(LRSH)
- SET LRSHN=$PIECE(X,U,1)
- SET LRTOPP=$PIECE(X,U,2)
- SET LRSHD=$PIECE(X,U,3)
- SET LRFMT=$PIECE(X,U,4)
- SET LRFMT(1)=$EXTRACT(LRFMT,1)
- SET LROFMT(1)=$EXTRACT(LROFMT,1)
- +2 IF (LROFMT["V"&(LRFMT["V"))!(LROFMT'=""&(LRFMT(1)'=LROFMT(1)))
- SET LROFMT=""
- DO HEAD^LRACSUM6
- +3 SET LROFMT=LRFMT
- SET LRTOPP=$EXTRACT($PIECE(^LAB(61,LRTOPP,0),U,1),1,13)
- SET LRTOT=0
- SET LRPL=1
- SET LRACT=0
- SET LRJS=0
- SET LRTS=0
- SET LRFDE=0
- +4 SET LRNP=0
- SET LRFDT=0
- SET LRLFDT=0
- SET LRFFDT=0
- DO LRNP
- LOOP ;from LRACSUM5
- +1 IF LRACT<LRPL
- SET LRFDT=LRFFDT
- if LRFMT["H"
- GOTO TS^LRACSUM5
- IF LRFMT["V"
- SET LRMULT=1
- SET LRMU=0
- DO MUL
- GOTO BS^LRACSUM4
- +2 DO TXT1^LRACSUM5
- IF LRCTR'<LRLNS!(IOSL-18<$Y)
- SET LRFULL=1
- if 'LRFDT
- SET LRFED=1
- if LRFDE
- DO LRBOT^LRACSUM6
- if 'LRFDT
- DO HEAD^LRACSUM6
- SET LRFULL=0
- GOTO LRSH
- +3 GOTO LRSH
- LRNP ;from LRACSUM4
- +1 SET I=0
- FOR
- SET I=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,I))
- if I<1
- QUIT
- SET LRTOT=LRTOT+$PIECE(^(I,0),U,2)
- IF LRTOT>(IOM-20)
- SET LRPL=LRPL+1
- SET LRTOT=$PIECE(^(0),U,2)
- LRLNS ;from LRACSUM5
- +1 KILL LRTM,^TMP($JOB,"TM")
- SET LRTM=0
- +2 SET LRLNS=((IOSL-18)-($Y+(6*LRPL)))\LRPL
- +3 SET LRCL=(IOM/2)-(5+($LENGTH(LRSHN)/2))
- WRITE !!?LRCL,"---- ",LRSHN," ----"
- +4 SET LRACT=0
- SET LRJS=0
- SET LRNP=1
- +5 QUIT
- UDT ;from LRACSUM4, LRACSUM5
- +1 SET LRBDT=LRFDT
- SET LRFDT=$SELECT($PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,0),U,3)["I":$PIECE(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,0),U,2),1:LRFDT)
- SET LRTIM=$EXTRACT(LRFDT,9,12)
- FOR I=0:0
- if $LENGTH(LRTIM)=4
- QUIT
- SET LRTIM=LRTIM_0
- +2 SET LRTIM=$SELECT(LRTIM?4"0":" ",1:$EXTRACT(LRTIM,1,2)_":"_$EXTRACT(LRTIM,3,4))
- +3 SET LRUDT=$EXTRACT($$Y2K^LRX($PIECE(LRFDT,".")),1,5)_" "_$JUSTIFY(LRTIM,4)_" "
- SET LRFDT=LRBDT
- if LRTM
- DO LRTM
- +4 QUIT
- LRTM SET LRNXSW=0
- if '$DATA(LRTM(0))
- SET LRTM(0)=96
- +1 IF $DATA(^TMP($JOB,"TM",LRFDT))
- SET LRNXSW=1
- +2 IF '$TEST
- IF $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX"))
- SET LRTM(0)=LRTM(0)+1
- SET LRNX=$CHAR(LRTM(0))
- SET ^TMP($JOB,"TM",LRFDT)=LRNX
- SET LRNXSW=1
- SET I=0
- FOR
- SET I=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX",I))
- if 'I
- QUIT
- SET ^TMP($JOB,"TM",LRFDT,I)=^(I,0)
- +3 ;S:LRNXSW LRUDT=$P(^TMP($J,"TM",LRFDT),U,1)_" "_LRUDT
- +4 DO Y2KALT^LRAC3
- +5 QUIT
- MUL FOR I=0:0
- if LRMULT*(LRSHD+15)>(IOSL-9)
- QUIT
- SET LRMULT=LRMULT+1
- +1 QUIT
