- 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 Feb 18, 2025@23:31:38 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