LR7OSUM4 ;DALOI/STAFF - Silent Patient cum cont. ;06/04/12 11:15
;;5.2;LAB SERVICE;**121,187,228,241,251,350**;Sep 27, 1994;Build 230
;
BS ;from LR7OSUM3
;
K I,Z,^TMP($J,"TY")
;
S LRCW=10,LRHI="",LRLO="",LRTT=1,I=0,LRTY=GIOM-28\10,LRMU=LRMU+1,LRII=0
;
F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 D
. S Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII,0),P3=$P(Z,U,3),P6=$P(Z,U,6),I=I+1,I(I)=LRII
. S ^TMP($J,"TY",0,I)=P3 S:P6 ^TMP($J,"TY",I,"D")=P6
K P3,P6
;
F K=1:1:(LRTY-1) S LRFDT=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT)) Q:LRFDT<1 D
. S Z=^TMP($J,LRDFN,LRMH,LRSH,LRFDT,0),^TMP($J,"TY",K,"L")=$P(Z,U,1),LRTT=LRTT+1
. D BS1
. S:LRFDT>LRLFDT LRLFDT=LRFDT
;
S:LRTT>(LRTY-1)&(LRMULT=1) LRFULL=1
S:LRTT>(LRTY-1)&(LRMU=(LRMULT-1)) LRFULL=1
F I=1:1:LRSHD D LRLO^LR7OSUM5 S:LRLOHI'="" ^TMP($J,"TY",(LRTT+1),I)=LRLOHI S:P7'="" ^TMP($J,"TY",LRTT,I)=P7
S ^TMP($J,"TY",LRTT,"T")="Units",^TMP($J,"TY",(LRTT+1),"T")="Ranges"
S ^TMP($J,"TY",(LRTT+1),0)=$S($P(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)'="":"Therapeutic",1:"Reference")
S ^TMP($J,"TY",LRTT,0)=""
;
D LINE,LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,$E(LRTOPP,1,15))_$$S^LR7OS(16,CCNT,"")
F I=1:1:(LRTT+1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"TY",I,0),10))
;
D LN
S XZ="",$P(XZ," ",3)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)_$$S^LR7OS(16,CCNT,"")
F I=1:1:(LRTT-1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"Y2K",I),10))
;
D LN
S XZ="",$P(XZ," ",3)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)_$$S^LR7OS(16,CCNT,"")
F I=1:1:(LRTT+1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"TY",I,"T"),10))
;
D LN
S XZ="-",$P(XZ,"-",GIOM)="",^TMP("LRC",$J,GCNT,0)=XZ
F I=1:1:LRSHD D
. S LRCL=16,LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
. D LN S ^TMP("LRC",$J,GCNT,0)=""
. D BS4
I $D(LRTX) D
. D LN S LRTX="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Comments: ")_$$S^LR7OS(16,CCNT,"")
. F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" D
. . S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(10*LRTX+2,CCNT,$P(^TMP("LRCMTINDX",$J,$P(LRTX(LRTX),"^")),"^"))
;
D TXT1^LR7OSUM5
S LROFDT=LRFDT
I $D(LRTX) D
. S LRTX=""
. F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" D
. . D LN
. . S LRFDT=LRTX(LRTX),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,$P(^TMP("LRCMTINDX",$J,LRFDT),"^")_". ")
. . D TXT^LR7OSUM5
S LRFDT=LROFDT
K LRTY,LRTX,^TMP($J,"TY")
I 'LRFDT G LRSH^LR7OSUM3
I $O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT))="" G LRSH^LR7OSUM3
S LRFDT=LRLFDT
I LRFULL D HEAD^LR7OSUM6,LRNP^LR7OSUM3 S LRFULL=0,LRMU=0
G BS
;
;
BS1 ;
N LRDATE
S LRDATE=$$FMTE^XLFDT(9999999-LRFDT,"1"_$S(+$P(Z,"^",6):"D",1:"M"))
S ^TMP($J,"TY",K,0)=$P(LRDATE,",",1)
S ^TMP($J,"TY",K,"T")=$P(LRDATE,"@",2)
S ^TMP($J,"Y2K",K)=$P($P(LRDATE," ",3),"@")
F J=1:1:LRSHD D
. S:$D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,I(J))) ^TMP($J,"TY",K,J)=^(I(J))
. S:$D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX"))&'$D(LRTX(LRTT)) LRTX(LRTT)=LRFDT
Q
;
;
BS2 ;
S X=$S($D(^TMP($J,"TY",J,I)):$P(^(I),U,1),1:"")
S X1=$S(X'="":$P(^TMP($J,"TY",J,I),U,2),1:"")
S LRDP=$S($D(^TMP($J,"TY",I,"D")):^("D"),1:""),LRCL=LRCL+10
K T1,T3
Q
;
;
BS4 ;
;
; Build test names on left column
N LROVRFL
S LROVRFL=""
S X=^TMP($J,"TY",0,I)
I $L(X)>15 S LROVRFL=$E(X,16,100)
S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(1,CCNT,$E(X,1,15))_$$S^LR7OS(16,CCNT,"")
S:'$P($G(^TMP("LRT",$J,X)),"^",2) $P(^TMP("LRT",$J,X),"^",2)=GCNT
;
; Print test results then unit/reference ranges
F J=1:1:(LRTT+1) D
. D BS2
. I X="" Q
. I J'<LRTT N LRDP S LRDP=""
. D C1^LR7OSUM5(.X,.X1)
. I $P(LRG,U,4)'=""&(J<LRTT) S @("X="_$P(LRG,"^",4)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10+8,CCNT,X_X1)
. I $P(LRG,U,4)=""!(J'<LRTT) S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10+8,CCNT,$J(X,LRCW))
;
; Handle overflow on test name, indent 1 character for readability
I LROVRFL'="" F S X=$E(LROVRFL,1,14),LROVRFL=$E(LROVRFL,15,100) Q:X="" S GCNT=GCNT+1,^TMP("LRC",$J,GCNT,0)=" "_X
;
Q
;
;
LN ; Increment the counter
S GCNT=GCNT+1,CCNT=1
Q
;
;
LINE ; Fill in the global with bank lines
N X
D LN
S X=" ",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSUM4 4303 printed Oct 16, 2024@18:06:30 Page 2
LR7OSUM4 ;DALOI/STAFF - Silent Patient cum cont. ;06/04/12 11:15
+1 ;;5.2;LAB SERVICE;**121,187,228,241,251,350**;Sep 27, 1994;Build 230
+2 ;
BS ;from LR7OSUM3
+1 ;
+2 KILL I,Z,^TMP($JOB,"TY")
+3 ;
+4 SET LRCW=10
SET LRHI=""
SET LRLO=""
SET LRTT=1
SET I=0
SET LRTY=GIOM-28\10
SET LRMU=LRMU+1
SET LRII=0
+5 ;
+6 FOR
SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
if LRII<1
QUIT
Begin DoDot:1
+7 SET Z=^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII,0)
SET P3=$PIECE(Z,U,3)
SET P6=$PIECE(Z,U,6)
SET I=I+1
SET I(I)=LRII
+8 SET ^TMP($JOB,"TY",0,I)=P3
if P6
SET ^TMP($JOB,"TY",I,"D")=P6
End DoDot:1
+9 KILL P3,P6
+10 ;
+11 FOR K=1:1:(LRTY-1)
SET LRFDT=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT))
if LRFDT<1
QUIT
Begin DoDot:1
+12 SET Z=^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,0)
SET ^TMP($JOB,"TY",K,"L")=$PIECE(Z,U,1)
SET LRTT=LRTT+1
+13 DO BS1
+14 if LRFDT>LRLFDT
SET LRLFDT=LRFDT
End DoDot:1
+15 ;
+16 if LRTT>(LRTY-1)&(LRMULT=1)
SET LRFULL=1
+17 if LRTT>(LRTY-1)&(LRMU=(LRMULT-1))
SET LRFULL=1
+18 FOR I=1:1:LRSHD
DO LRLO^LR7OSUM5
if LRLOHI'=""
SET ^TMP($JOB,"TY",(LRTT+1),I)=LRLOHI
if P7'=""
SET ^TMP($JOB,"TY",LRTT,I)=P7
+19 SET ^TMP($JOB,"TY",LRTT,"T")="Units"
SET ^TMP($JOB,"TY",(LRTT+1),"T")="Ranges"
+20 SET ^TMP($JOB,"TY",(LRTT+1),0)=$SELECT($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)'="":"Therapeutic",1:"Reference")
+21 SET ^TMP($JOB,"TY",LRTT,0)=""
+22 ;
+23 DO LINE
DO LN
+24 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,$EXTRACT(LRTOPP,1,15))_$$S^LR7OS(16,CCNT,"")
+25 FOR I=1:1:(LRTT+1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"TY",I,0),10))
+26 ;
+27 DO LN
+28 SET XZ=""
SET $PIECE(XZ," ",3)=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)_$$S^LR7OS(16,CCNT,"")
+29 FOR I=1:1:(LRTT-1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"Y2K",I),10))
+30 ;
+31 DO LN
+32 SET XZ=""
SET $PIECE(XZ," ",3)=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)_$$S^LR7OS(16,CCNT,"")
+33 FOR I=1:1:(LRTT+1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"TY",I,"T"),10))
+34 ;
+35 DO LN
+36 SET XZ="-"
SET $PIECE(XZ,"-",GIOM)=""
SET ^TMP("LRC",$JOB,GCNT,0)=XZ
+37 FOR I=1:1:LRSHD
Begin DoDot:1
+38 SET LRCL=16
SET LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
+39 DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=""
+40 DO BS4
End DoDot:1
+41 IF $DATA(LRTX)
Begin DoDot:1
+42 DO LN
SET LRTX=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Comments: ")_$$S^LR7OS(16,CCNT,"")
+43 FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
if LRTX=""
QUIT
Begin DoDot:2
+44 SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(10*LRTX+2,CCNT,$PIECE(^TMP("LRCMTINDX",$JOB,$PIECE(LRTX(LRTX),"^")),"^"))
End DoDot:2
End DoDot:1
+45 ;
+46 DO TXT1^LR7OSUM5
+47 SET LROFDT=LRFDT
+48 IF $DATA(LRTX)
Begin DoDot:1
+49 SET LRTX=""
+50 FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
if LRTX=""
QUIT
Begin DoDot:2
+51 DO LN
+52 SET LRFDT=LRTX(LRTX)
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,$PIECE(^TMP("LRCMTINDX",$JOB,LRFDT),"^")_". ")
+53 DO TXT^LR7OSUM5
End DoDot:2
End DoDot:1
+54 SET LRFDT=LROFDT
+55 KILL LRTY,LRTX,^TMP($JOB,"TY")
+56 IF 'LRFDT
GOTO LRSH^LR7OSUM3
+57 IF $ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT))=""
GOTO LRSH^LR7OSUM3
+58 SET LRFDT=LRLFDT
+59 IF LRFULL
DO HEAD^LR7OSUM6
DO LRNP^LR7OSUM3
SET LRFULL=0
SET LRMU=0
+60 GOTO BS
+61 ;
+62 ;
BS1 ;
+1 NEW LRDATE
+2 SET LRDATE=$$FMTE^XLFDT(9999999-LRFDT,"1"_$SELECT(+$PIECE(Z,"^",6):"D",1:"M"))
+3 SET ^TMP($JOB,"TY",K,0)=$PIECE(LRDATE,",",1)
+4 SET ^TMP($JOB,"TY",K,"T")=$PIECE(LRDATE,"@",2)
+5 SET ^TMP($JOB,"Y2K",K)=$PIECE($PIECE(LRDATE," ",3),"@")
+6 FOR J=1:1:LRSHD
Begin DoDot:1
+7 if $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,I(J)))
SET ^TMP($JOB,"TY",K,J)=^(I(J))
+8 if $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX"))&'$DATA(LRTX(LRTT))
SET LRTX(LRTT)=LRFDT
End DoDot:1
+9 QUIT
+10 ;
+11 ;
BS2 ;
+1 SET X=$SELECT($DATA(^TMP($JOB,"TY",J,I)):$PIECE(^(I),U,1),1:"")
+2 SET X1=$SELECT(X'="":$PIECE(^TMP($JOB,"TY",J,I),U,2),1:"")
+3 SET LRDP=$SELECT($DATA(^TMP($JOB,"TY",I,"D")):^("D"),1:"")
SET LRCL=LRCL+10
+4 KILL T1,T3
+5 QUIT
+6 ;
+7 ;
BS4 ;
+1 ;
+2 ; Build test names on left column
+3 NEW LROVRFL
+4 SET LROVRFL=""
+5 SET X=^TMP($JOB,"TY",0,I)
+6 IF $LENGTH(X)>15
SET LROVRFL=$EXTRACT(X,16,100)
+7 SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(1,CCNT,$EXTRACT(X,1,15))_$$S^LR7OS(16,CCNT,"")
+8 if '$PIECE($GET(^TMP("LRT",$JOB,X)),"^",2)
SET $PIECE(^TMP("LRT",$JOB,X),"^",2)=GCNT
+9 ;
+10 ; Print test results then unit/reference ranges
+11 FOR J=1:1:(LRTT+1)
Begin DoDot:1
+12 DO BS2
+13 IF X=""
QUIT
+14 IF J'<LRTT
NEW LRDP
SET LRDP=""
+15 DO C1^LR7OSUM5(.X,.X1)
+16 IF $PIECE(LRG,U,4)'=""&(J<LRTT)
SET @("X="_$PIECE(LRG,"^",4))
SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(J*10+8,CCNT,X_X1)
+17 IF $PIECE(LRG,U,4)=""!(J'<LRTT)
SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(J*10+8,CCNT,$JUSTIFY(X,LRCW))
End DoDot:1
+18 ;
+19 ; Handle overflow on test name, indent 1 character for readability
+20 IF LROVRFL'=""
FOR
SET X=$EXTRACT(LROVRFL,1,14)
SET LROVRFL=$EXTRACT(LROVRFL,15,100)
if X=""
QUIT
SET GCNT=GCNT+1
SET ^TMP("LRC",$JOB,GCNT,0)=" "_X
+21 ;
+22 QUIT
+23 ;
+24 ;
LN ; Increment the counter
+1 SET GCNT=GCNT+1
SET CCNT=1
+2 QUIT
+3 ;
+4 ;
LINE ; Fill in the global with bank lines
+1 NEW X
+2 DO LN
+3 SET X=" "
SET $PIECE(X," ",GIOM)=""
SET ^TMP("LRC",$JOB,GCNT,0)=X
+4 QUIT
