- LRACSUM5 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY ; 3/3/88 13:32 ;
- ;;5.2;LAB SERVICE;**225**;Sep 27, 1994
- TS ;from LRACSUM3
- I LRACT'=0 D EQUALS^LRX
- K I S I=0,LRII=0 F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 S I=I+1,I(I)=LRII
- S LRFALT=0,LRCTR=0,LRACT=LRACT+1,J=LRJS+1,LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20)
- I J'>LRSHD W !! W:$D(LRCALE(LRMH,LRSH)) "Locale " W LRTOPP,?LRCL
- F I=J:1:LRSHD S Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),LRCW=$P(Z,U,2) Q:(IOM-LRCL)<LRCW S LRCL=LRCL+LRCW,A=$L($P(Z,U,3))\2,B=LRCW\2 W $J($E($P(Z,U,3),1,(LRCW-1)),(A+B)),?LRCL
- S LRJS=(I-1) S:LRACT=LRPL LRJS=LRJS+1
- F I=J:1:LRJS Q:'$D(^LAB(64.5,"A",1,LRMH,LRSH,I(I))) S Z=^(I(I)) S:$L($P(Z,U,2))!$L($P(Z,U,11)) LRFALT=1
- S LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20)
- I LRFALT W ! W:$D(LRCALE(LRMH,LRSH)) ?9 W $S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(J)),U,11)):"Therapeutic",1:"Ref range"),?LRCL D TS1
- F I=J:1:LRJS Q:'$D(^LAB(64.5,"A",1,LRMH,LRSH,I(I))) S:$L($P(^(I(I)),U,7)) LRFALT=1
- I LRFALT S LRCL=$S($D(LRCALE(LRMH,LRSH)):24,1:20) W !?LRCL F I=J:1:LRJS D TS2
- S LRFALT=0 D DASH^LRX
- LRFDT K A,B S:LRNP LRFFDT=LRFDT,LRNP=0 S LRFDT=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT)) G:LRFDT<1 LOOP^LRACSUM3 S LRTLOC=$P(^(LRFDT,0),U,1)
- S:LRFDT>LRLFDT LRLFDT=LRFDT
- GOUT D QRS I LRCTR>LRLNS&(LRACT'<LRPL) S LRFULL=1 D TXT1 G:$O(^TMP($J,LRDFN,LRMH,LRSH,LRLFDT))<1 LRSH^LRACSUM3 D HEAD^LRACSUM6,LRLNS^LRACSUM3 S LRFULL=0,LRFDT=LRLFDT G TS
- I LRCTR>LRLNS&(LRACT<LRPL) S LRFDT=LRFFDT G TS
- G LRFDT
- QRS S LRCTR=LRCTR+1 F I=J:1:LRJS I $D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,I(I))) S:$L(^(I(I))) LRFALT=1
- Q:'LRFALT
- S LRFALT=0,LRTM=1 D UDT^LRACSUM3 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
- 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(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,I(I))) S X=^(I(I)) 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
- TXT ;from LRACSUM4
- S LRVAR=0
- S LRIV=0 F S LRIV=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX",LRIV)) Q:'LRIV S LRVAR=LRVAR+1 W:LRVAR>1 !?3 W ^(LRIV,0)
- Q
- C2 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
- LRLO ;from LRACSUM4
- 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
- TXT1 ;from LRACSUM3, LRACSUM4
- 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="" 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
- C S X1=" "_$P(X,U,2),X=$P(X,U,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)) D C2
- Q
- C1 ;from LRACSUM4
- 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
- TS1 F I=J:1:LRJS S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2),LRCL=LRCL+LRCW D LRLO S A=$L(LRLOHI)\2,B=LRCW\2 W $J(LRLOHI,(A+B)),?LRCL
- Q
- TS2 S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2) Q:(IOM-LRCL)<LRCW S LRCL=LRCL+LRCW,A=$L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,7))\2,B=LRCW\2 W $J($P(^(I(I)),U,7),(A+B)),?LRCL S LRFALT=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACSUM5 3978 printed Feb 18, 2025@23:32:32 Page 2
- LRACSUM5 ;SLC/DCM - PRINT INDIVIDUAL PATIENT SUMMARY ; 3/3/88 13:32 ;
- +1 ;;5.2;LAB SERVICE;**225**;Sep 27, 1994
- TS ;from LRACSUM3
- +1 IF LRACT'=0
- DO EQUALS^LRX
- +2 KILL I
- SET I=0
- SET LRII=0
- FOR
- SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
- if LRII<1
- QUIT
- SET I=I+1
- SET I(I)=LRII
- +3 SET LRFALT=0
- SET LRCTR=0
- SET LRACT=LRACT+1
- SET J=LRJS+1
- SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- +4 IF J'>LRSHD
- WRITE !!
- if $DATA(LRCALE(LRMH,LRSH))
- WRITE "Locale "
- WRITE LRTOPP,?LRCL
- +5 FOR I=J:1:LRSHD
- SET Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
- SET LRCW=$PIECE(Z,U,2)
- if (IOM-LRCL)<LRCW
- QUIT
- SET LRCL=LRCL+LRCW
- SET A=$LENGTH($PIECE(Z,U,3))\2
- SET B=LRCW\2
- WRITE $JUSTIFY($EXTRACT($PIECE(Z,U,3),1,(LRCW-1)),(A+B)),?LRCL
- +6 SET LRJS=(I-1)
- if LRACT=LRPL
- SET LRJS=LRJS+1
- +7 FOR I=J:1:LRJS
- if '$DATA(^LAB(64.5,"A",1,LRMH,LRSH,I(I)))
- QUIT
- SET Z=^(I(I))
- if $LENGTH($PIECE(Z,U,2))!$LENGTH($PIECE(Z,U,11))
- SET LRFALT=1
- +8 SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- +9 IF LRFALT
- WRITE !
- if $DATA(LRCALE(LRMH,LRSH))
- WRITE ?9
- WRITE $SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(J)),U,11)):"Therapeutic",1:"Ref range"),?LRCL
- DO TS1
- +10 FOR I=J:1:LRJS
- if '$DATA(^LAB(64.5,"A",1,LRMH,LRSH,I(I)))
- QUIT
- if $LENGTH($PIECE(^(I(I)),U,7))
- SET LRFALT=1
- +11 IF LRFALT
- SET LRCL=$SELECT($DATA(LRCALE(LRMH,LRSH)):24,1:20)
- WRITE !?LRCL
- FOR I=J:1:LRJS
- DO TS2
- +12 SET LRFALT=0
- DO DASH^LRX
- LRFDT KILL A,B
- if LRNP
- SET LRFFDT=LRFDT
- SET LRNP=0
- SET LRFDT=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT))
- if LRFDT<1
- GOTO LOOP^LRACSUM3
- SET LRTLOC=$PIECE(^(LRFDT,0),U,1)
- +1 if LRFDT>LRLFDT
- SET LRLFDT=LRFDT
- GOUT DO QRS
- IF LRCTR>LRLNS&(LRACT'<LRPL)
- SET LRFULL=1
- DO TXT1
- if $ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRLFDT))<1
- GOTO LRSH^LRACSUM3
- DO HEAD^LRACSUM6
- DO LRLNS^LRACSUM3
- SET LRFULL=0
- SET LRFDT=LRLFDT
- GOTO TS
- +1 IF LRCTR>LRLNS&(LRACT<LRPL)
- SET LRFDT=LRFFDT
- GOTO TS
- +2 GOTO LRFDT
- QRS SET LRCTR=LRCTR+1
- FOR I=J:1:LRJS
- IF $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,I(I)))
- if $LENGTH(^(I(I)))
- SET LRFALT=1
- +1 if 'LRFALT
- QUIT
- +2 SET LRFALT=0
- SET LRTM=1
- DO UDT^LRACSUM3
- 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
- +3 FOR I=J:1:LRJS
- SET LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
- DO QRS1
- +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(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,I(I)))
- SET X=^(I(I))
- 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
- TXT ;from LRACSUM4
- +1 SET LRVAR=0
- +2 SET LRIV=0
- FOR
- SET LRIV=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX",LRIV))
- if 'LRIV
- QUIT
- SET LRVAR=LRVAR+1
- if LRVAR>1
- WRITE !?3
- WRITE ^(LRIV,0)
- +3 QUIT
- C2 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
- +1 KILL X3
- QUIT
- LRLO ;from LRACSUM4
- +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
- TXT1 ;from LRACSUM3, LRACSUM4
- +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
- 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
- C SET X1=" "_$PIECE(X,U,2)
- SET X=$PIECE(X,U,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))
- DO C2
- +5 QUIT
- C1 ;from LRACSUM4
- +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
- TS1 FOR I=J:1:LRJS
- SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
- SET LRCL=LRCL+LRCW
- DO LRLO
- SET A=$LENGTH(LRLOHI)\2
- SET B=LRCW\2
- WRITE $JUSTIFY(LRLOHI,(A+B)),?LRCL
- +1 QUIT
- TS2 SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0),U,2)
- if (IOM-LRCL)<LRCW
- QUIT
- SET LRCL=LRCL+LRCW
- SET A=$LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(I)),U,7))\2
- SET B=LRCW\2
- WRITE $JUSTIFY($PIECE(^(I(I)),U,7),(A+B)),?LRCL
- SET LRFALT=0
- +1 QUIT
