- LR7OSUM3 ;DALOI/STAFF - Silent Patient cum cont. ;02/20/13 16:5
- ;;5.2;LAB SERVICE;**121,201,187,228,250,350,427**;Sep 27, 1994;Build 33
- ;
- N GIOM,LRPF,LRI
- S GIOM=$G(LRGIOM)
- I GIOM="" D
- . S GIOM=$$GET^XPAR("USR^DIV^PKG","LR CH GUI REPORT RIGHT MARGIN",1,"Q")
- . I GIOM="" S GIOM=80
- S LRAG=0,LRYESCOM=0,LRIL=0,LRFULL=0
- ;
- ; Print header with name of facility printing report.
- I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D PFAC
- ;
- D LRMH S LRMH="MISC"
- G PRE^LR7OSUM6
- ;
- 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^LR7OSUM6
- S LROFMT="",LRFDE=0 D LRSH
- D:'LRFDE LRBOT^LR7OSUM6
- K LRTM,^TMP($J,"TM")
- S LRFULL=0,LRTM=0,LROFMT="",LRFDE=0
- Q
- ;
- ;
- LRSH ;from LR7OSUM4, LR7OSUM5
- 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)
- Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD(LRSHN)))
- I (LROFMT["V"&(LRFMT["V"))!(LROFMT'=""&(LRFMT(1)'=LROFMT(1))) S LROFMT="" D HEAD^LR7OSUM6
- 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 LR7OSUM5
- I LRACT<LRPL S LRFDT=LRFFDT G:LRFMT["H" TS^LR7OSUM5 I LRFMT["V" S LRMULT=99999,LRMU=0 G BS^LR7OSUM4
- D TXT1^LR7OSUM5
- I LRCTR'<LRLNS S LRFULL=1 S:'LRFDT LRFED=1 D:LRFDE LRBOT^LR7OSUM6 D:'LRFDT HEAD^LR7OSUM6 S LRFULL=0 G LRSH
- G LRSH
- ;
- ;
- LRNP ;from LR7OSUM4
- S I=0 F S I=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,I)) Q:I<1 D
- . N LRCW
- . S LRCW=$P(^LAB(64.5,1,1,LRMH,1,LRSH,1,I,0),U,2)
- . I LRCW<1 S LRCW=15
- . S LRTOT=LRTOT+LRCW
- . I LRTOT>(GIOM-25) S LRPL=LRPL+1,LRTOT=LRCW
- LRLNS ;from LR7OSUM5
- K LRTM,^TMP($J,"TM") S LRTM=0
- S LRLNS=((GIOSL-18)-(GCNT+(6*LRPL)))\LRPL
- S LRCL=(GIOM/2)-(5+($L(LRSHN)/2)) S GCNT=GCNT+1,CCNT=1,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(LRCL,CCNT,"---- "_LRSHN_" ----")
- S ^TMP("LRH",$J,LRSHN)=GCNT ;Set x-ref of minor headers with data
- S LRACT=0,LRJS=0,LRNP=1
- Q
- ;
- ;
- UDT ;from LR7OSUM4, LR7OSUM5
- N LRBDT,LREAL
- S LRBDT=LRFDT
- ; If inexact date/time then suppress any pseudo time.
- S LREAL=+$P(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,0),U,6)
- ; Forces all formats to be inverse date/time regardless of parameter in file 64.5
- S LRFDT=$P(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,0),U,2) ;,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")) D
- . S ^TMP($J,"TM",LRFDT)=^TMP("LRCMTINDX",$J,LRFDT),LRNXSW=1
- . S I=0 F S I=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX",I)) Q:I<1 S ^TMP($J,"TM",LRFDT,I)=^(I,0)
- N LRUDT7
- ;S LRUDT7=$$Y2K^LRX(9999999-LRFDT)
- ;S LRUDT7=$$FMTE^XLFDT(9999999-LRFDT,"1"_$S(LREAL:"D",1:"M"))
- S LRUDT7=$$LRUDT^LR7OSUM6(9999999-LRFDT,LREAL)
- S LRUDT=$P(LRUDT7,"@")_" "_$E($P(LRUDT7,"@",2),1,5)
- ;S:LRNXSW I=$P(^TMP($J,"TM",LRFDT),"^"),LRUDT=I_$E(" ",1,$S(I'="":1,1:2))_LRUDT
- I LRNXSW D
- . S I=$P(^TMP($J,"TM",LRFDT),"^")
- . I I'="" S I="["_I_"]"
- . S LRUDT=$$LJ^XLFSTR(I,5)_LRUDT_" "
- Q
- ;
- ;
- PFAC ; Print header with name of facility printing report.
- ;
- D PFAC^LRRP1(DUZ(2),0,1,.LRPF)
- I ($O(^TMP($J,LRDFN,0))!($O(^TMP($J,LRDFN,"MISC",0)))),$D(LRPF) D
- . S LRI=0
- . F S LRI=$O(LRPF(LRI)) Q:'LRI D LN^LR7OSUM4 S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,LRPF(LRI))
- . D LINE^LR7OSUM4 S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,"As of: "_$$HTE^XLFDT($H,"1M"))
- . D LINE^LR7OSUM4,LINE^LR7OSUM4
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSUM3 3804 printed Feb 18, 2025@23:31:37 Page 2
- LR7OSUM3 ;DALOI/STAFF - Silent Patient cum cont. ;02/20/13 16:5
- +1 ;;5.2;LAB SERVICE;**121,201,187,228,250,350,427**;Sep 27, 1994;Build 33
- +2 ;
- +3 NEW GIOM,LRPF,LRI
- +4 SET GIOM=$GET(LRGIOM)
- +5 IF GIOM=""
- Begin DoDot:1
- +6 SET GIOM=$$GET^XPAR("USR^DIV^PKG","LR CH GUI REPORT RIGHT MARGIN",1,"Q")
- +7 IF GIOM=""
- SET GIOM=80
- End DoDot:1
- +8 SET LRAG=0
- SET LRYESCOM=0
- SET LRIL=0
- SET LRFULL=0
- +9 ;
- +10 ; Print header with name of facility printing report.
- +11 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
- DO PFAC
- +12 ;
- +13 DO LRMH
- SET LRMH="MISC"
- +14 GOTO PRE^LR7OSUM6
- +15 ;
- LRMH SET LRMH=0
- +1 FOR
- SET LRMH=$ORDER(^TMP($JOB,LRDFN,LRMH))
- if LRMH<1
- QUIT
- SET X=^(LRMH)
- DO MH1
- +2 QUIT
- +3 ;
- +4 ;
- MH1 SET LRMHN=$PIECE(X,U,1)
- SET LRSH=0
- +1 SET LRPG=1
- +2 DO TOP^LR7OSUM6
- +3 SET LROFMT=""
- SET LRFDE=0
- DO LRSH
- +4 if 'LRFDE
- DO LRBOT^LR7OSUM6
- +5 KILL LRTM,^TMP($JOB,"TM")
- +6 SET LRFULL=0
- SET LRTM=0
- SET LROFMT=""
- SET LRFDE=0
- +7 QUIT
- +8 ;
- +9 ;
- LRSH ;from LR7OSUM4, LR7OSUM5
- +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 $SELECT('$DATA(SUBHEAD)
- QUIT
- +3 IF (LROFMT["V"&(LRFMT["V"))!(LROFMT'=""&(LRFMT(1)'=LROFMT(1)))
- SET LROFMT=""
- DO HEAD^LR7OSUM6
- +4 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
- +5 SET LRNP=0
- SET LRFDT=0
- SET LRLFDT=0
- SET LRFFDT=0
- DO LRNP
- +6 ;
- LOOP ;from LR7OSUM5
- +1 IF LRACT<LRPL
- SET LRFDT=LRFFDT
- if LRFMT["H"
- GOTO TS^LR7OSUM5
- IF LRFMT["V"
- SET LRMULT=99999
- SET LRMU=0
- GOTO BS^LR7OSUM4
- +2 DO TXT1^LR7OSUM5
- +3 IF LRCTR'<LRLNS
- SET LRFULL=1
- if 'LRFDT
- SET LRFED=1
- if LRFDE
- DO LRBOT^LR7OSUM6
- if 'LRFDT
- DO HEAD^LR7OSUM6
- SET LRFULL=0
- GOTO LRSH
- +4 GOTO LRSH
- +5 ;
- +6 ;
- LRNP ;from LR7OSUM4
- +1 SET I=0
- FOR
- SET I=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,I))
- if I<1
- QUIT
- Begin DoDot:1
- +2 NEW LRCW
- +3 SET LRCW=$PIECE(^LAB(64.5,1,1,LRMH,1,LRSH,1,I,0),U,2)
- +4 IF LRCW<1
- SET LRCW=15
- +5 SET LRTOT=LRTOT+LRCW
- +6 IF LRTOT>(GIOM-25)
- SET LRPL=LRPL+1
- SET LRTOT=LRCW
- End DoDot:1
- LRLNS ;from LR7OSUM5
- +1 KILL LRTM,^TMP($JOB,"TM")
- SET LRTM=0
- +2 SET LRLNS=((GIOSL-18)-(GCNT+(6*LRPL)))\LRPL
- +3 SET LRCL=(GIOM/2)-(5+($LENGTH(LRSHN)/2))
- SET GCNT=GCNT+1
- SET CCNT=1
- SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(LRCL,CCNT,"---- "_LRSHN_" ----")
- +4 ;Set x-ref of minor headers with data
- SET ^TMP("LRH",$JOB,LRSHN)=GCNT
- +5 SET LRACT=0
- SET LRJS=0
- SET LRNP=1
- +6 QUIT
- +7 ;
- +8 ;
- UDT ;from LR7OSUM4, LR7OSUM5
- +1 NEW LRBDT,LREAL
- +2 SET LRBDT=LRFDT
- +3 ; If inexact date/time then suppress any pseudo time.
- +4 SET LREAL=+$PIECE(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,0),U,6)
- +5 ; Forces all formats to be inverse date/time regardless of parameter in file 64.5
- +6 ;,LRTIM=$E(LRFDT,9,12)
- SET LRFDT=$PIECE(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,0),U,2)
- +7 ;F I=0:0 Q:$L(LRTIM)=4 S LRTIM=LRTIM_0
- +8 ;S LRTIM=$S(LRTIM?4"0":" ",1:$E(LRTIM,1,2)_":"_$E(LRTIM,3,4))
- +9 ;S LRUDT=$E($$Y2K^LRX($P(LRFDT,".")),1,5)_" "_$J(LRTIM,4)_" "
- +10 SET LRFDT=LRBDT
- if LRTM
- DO LRTM
- +11 QUIT
- +12 ;
- +13 ;
- LRTM ;
- +1 SET LRNXSW=0
- if '$DATA(LRTM(0))
- SET LRTM(0)=96
- +2 IF $DATA(^TMP($JOB,"TM",LRFDT))
- SET LRNXSW=1
- +3 IF '$TEST
- IF $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX"))
- Begin DoDot:1
- +4 SET ^TMP($JOB,"TM",LRFDT)=^TMP("LRCMTINDX",$JOB,LRFDT)
- SET LRNXSW=1
- +5 SET I=0
- FOR
- SET I=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX",I))
- if I<1
- QUIT
- SET ^TMP($JOB,"TM",LRFDT,I)=^(I,0)
- End DoDot:1
- +6 NEW LRUDT7
- +7 ;S LRUDT7=$$Y2K^LRX(9999999-LRFDT)
- +8 ;S LRUDT7=$$FMTE^XLFDT(9999999-LRFDT,"1"_$S(LREAL:"D",1:"M"))
- +9 SET LRUDT7=$$LRUDT^LR7OSUM6(9999999-LRFDT,LREAL)
- +10 SET LRUDT=$PIECE(LRUDT7,"@")_" "_$EXTRACT($PIECE(LRUDT7,"@",2),1,5)
- +11 ;S:LRNXSW I=$P(^TMP($J,"TM",LRFDT),"^"),LRUDT=I_$E(" ",1,$S(I'="":1,1:2))_LRUDT
- +12 IF LRNXSW
- Begin DoDot:1
- +13 SET I=$PIECE(^TMP($JOB,"TM",LRFDT),"^")
- +14 IF I'=""
- SET I="["_I_"]"
- +15 SET LRUDT=$$LJ^XLFSTR(I,5)_LRUDT_" "
- End DoDot:1
- +16 QUIT
- +17 ;
- +18 ;
- PFAC ; Print header with name of facility printing report.
- +1 ;
- +2 DO PFAC^LRRP1(DUZ(2),0,1,.LRPF)
- +3 IF ($ORDER(^TMP($JOB,LRDFN,0))!($ORDER(^TMP($JOB,LRDFN,"MISC",0))))
- IF $DATA(LRPF)
- Begin DoDot:1
- +4 SET LRI=0
- +5 FOR
- SET LRI=$ORDER(LRPF(LRI))
- if 'LRI
- QUIT
- DO LN^LR7OSUM4
- SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,LRPF(LRI))
- +6 DO LINE^LR7OSUM4
- SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,"As of: "_$$HTE^XLFDT($HOROLOG,"1M"))
- +7 DO LINE^LR7OSUM4
- DO LINE^LR7OSUM4
- End DoDot:1
- +8 QUIT