LRRP2.m

LRRP2 ;DALOI/OIT/RWF-INTERIM REPORT ; 01-Jun-2016 06:24 ; MKK

 ;;5.2;LAB SERVICE;**1003,1018,1019,1021,1022,1025,1027,1038,1039**;NOV 01, 1997;Build 38

 ;;5.2;LAB SERVICE;**106,121,221,283,300**;Sep 27, 1994

 ;from option LRRP2

 ;

BEGIN D INIT K DIC S LRPRTPG=0 D ^LRDPA D:LRDFN>0 START G:LRDFN<0 END G BEGIN

END D ^LRRK

 Q

CUM ;ENTRY POINT FOR CUMULATIVE OPTIONS- LRAC PT,LRAC 1 PAGE, LRAC MANUAL

 S LRPRTPG=1

 ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 ; If the BLR MASTER CONTROL file's INTERIM REPORT ADDRESS field 

 ; is set to NO, set flag.

 ; I $P($G(^BLRSITE(+$G(DUZ(2)),3)),"^",4)="N" S LRPRTPG=0

 ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 ; 

 ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 I $$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")["N" S LRPRTPG=0

 ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 ; 

SUM ;ENTRY POINT FROM SUM^LRACM2- PRINT A FULL PATIENT SUMMARY

 D INIT K DIC D ^LRDPA D:LRDFN>0 START G:LRDFN<0 END

 Q

START I $O(^LR(LRDFN,0))="" W !,"NO LAB DATA ON THIS PATIENT!",$C(7) Q

 S LRLAB=$S($D(LRLABKY):1,1:0)

 I $D(LRCUM) S LRIDT=0,LREDT=9999999

 E  D

 . S LREDT="T-7" D ^LRWU3 Q:LREND

 . S LRIDT=9999999-LRSDT,LREDT=9999999-LREDT

 I LREND Q

 ;

ASKPG I '$G(LRPRTPG) D

 . ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 . ; If INTERIM REPORT ADDRESS PAGE filed set, don't ask Question

 . NEW IRPTADDP

 . S IRPTADDP=$$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")

 . I IRPTADDP["N" S LRPRTPG=0  Q

 . I IRPTADDP["Y" S LRPRTPG=1  Q

 . ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 . ; 

 . S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO",LRPRTPG=0

 . D ^DIR K DIR

 . I Y S LRPRTPG=1

 S %ZIS="Q",ZTSAVE("DFN")="",ZTSAVE("LR*")="",ZTRTN="SDQ^LRRP2"

 D IO^LRWU

 Q

 ;

 ;

SDQ ; dequeued

 S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX

 F  S LRCNIDT=+$O(^LR(LRDFN,"CH",LRIDT)),LRMNIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:'LRCNIDT&'LRMNIDT  D SWITCH Q:LREND!LRSTOP!(LRIDT>LREDT)

 ; D FOOT^LRRP1

 D LASTFOOT

 ; D:$G(LRPRTPG) PLSPG

 D PLSPG      ; IHS/MSC/MKK - LR*5.2*1038

 Q

 ;

SWITCH I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT  D CH,MI Q

 I 'LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT  D CH Q

 I 'LRCNIDT S LRIDT=LRMNIDT Q:LRIDT>LREDT  D MI Q

 I LRCNIDT<LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT  D CH Q

 S LRIDT=LRMNIDT Q:LRIDT>LREDT  D MI

 Q

 ;

GENP W !!,"Too many tests!  Will use alternate format.  May show extra tests.",!

 S LREDT="T-7" D ^LRWU3 Q:LREND  S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT

 K ^TMP("LR",$J,"T"),LRORD,LRTSTS S ZTSAVE("^TMP(""LR"",$J,")="",ZTSAVE("DFN")="",ZTRTN="GDQ^LRRP2" D IO^LRWU

 Q

 ;

GDQ ;dequeued

 S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX

 S LRSUB="" F  S LRSUB=$O(^TMP("LR",$J,"TMP",LRSUB)) Q:LRSUB=""  S X=+$P(LRSUB,";",2),^TMP("LR",$J,"T",X)=""

 S LRIDT=LRSDT F  S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LREDT)  D GEN2 Q:LREND!LRSTOP

 K ^TMP("LR",$J,"T"),^TMP("LR",$J,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT

 Q

 ;

GEN2 S LRTN=0 F  S LRTN=$O(^LR(LRDFN,"CH",LRIDT,LRTN)) Q:LRTN<1  I $D(^TMP("LR",$J,"T",LRTN)) D CH Q

 I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3),$O(^LR(LRDFN,"CH",LRIDT,1,0)) D  Q:'$G(LRCAN)  D CH

 . S LRCAN=0 F  S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1  Q:$E($G(^(LRCAN,0)))="*"

 Q

 ;

 ;

AIDQUE ;

 D INIT

 S LRLAB=$S($D(LRLABKY):1,1:0)

 K ^TMP($J)

 S LROCE=$S($D(LROC):LROC,1:""),LROC=$S(LROCE="":$O(^LAB(64.6,"AI","")),1:LROC)

 D:LROC'="" AI2

 F  S LROC=$O(^LAB(64.6,"AI",LROC)) Q:LROC=""!($L(LROCE)&(LROC'=LROCE))  D AI2

 S LROC="UNKNOWN" D AI2

 ;

PRT ; Print sorted data

 ;U IO K VA D KVAR^VADPT S LREND=0

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ;U IO K VA D KVAR^BLRDPT S LREND=0  ;IHS/OIRM TUC/MJL

 U IO K VA D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT") S LREND=0

 ;----- END IHS MODIFICATIONS

 I $O(^TMP($J,0))="" D  Q

 . W !!?10,"No Interim report Patients to Print "

 . W !?20,$$HTE^XLFDT($H),!!

 . D QUIT

 S LROC=""

 F  S LROC=$O(^TMP($J,LROC)) Q:LROC=""!($G(LREND))  D

 . S LRPHY=""

 . F  S LRPHY=$O(^TMP($J,LROC,LRPHY)) Q:LRPHY=""!($G(LREND))  D

 . . S LRSSN=""

 . . F  S LRSSN=$O(^TMP($J,LROC,LRPHY,LRSSN)) Q:LRSSN=""!($G(LREND))  D

 . . . S LRDFN=0

 . . . F  S LRHF=1,LRDFN=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN)) Q:LRDFN<1!($G(LREND))  D

 . . . . S LRIDT=0

 . . . . F  S LRIDT=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)) Q:LRIDT<1!($G(LREND))  D

 . . . . . S LRSS="",PNM=^(LRIDT),SSN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0

 . . . . .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 . . . . . S LRSS="",PNM=^(LRIDT),HRCN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0  ;IHS/ANMC/CLS 08/18/96

 . . . . .;----- END IHS MODIFICATIONS

 . . . . . D:$D(^LR(LRDFN,"CH",LRIDT,0))#2 CH

 . . . . . S LRFOOT=0

 . . . . . I $D(^LR(LRDFN,"MI",LRIDT,0))#2 D

 . . . . . . I $G(LRSS)="CH" D FOOT^LRRP1 D:$G(LRPRTPG) PLSPG

 . . . . . . D MI

 . . . . . ;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Don't use FOOT^LRRP1 in the loop

 . . . . . ; I $G(LRSS)="CH" D FOOT^LRRP1 D:$G(LRPRTPG) PLSPG

 . . . . . I $G(LRSS)="CH" D:$G(LRPRTPG) PLSPG

 . . . . . ;----- END IHS MODIFICATIONS LR*5.2*1022

 D FOOT^LRRP1

 D QUIT

 Q

 ;

 ;

QUIT ;

 S:$D(ZTQUEUED) ZTREQ="@"

 D ^%ZISC,^LRRK

 Q

 ;

 ;

AI2 ;

 Q:'$L($G(LROC))

 F LRDFN=0:0 S LRDFN=$O(^LRO(69,"AN",LROC,LRDFN)) Q:LRDFN<1  I $D(^LR(LRDFN,0))#2 D

 . S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX Q:LREND

 . I '$G(VAERR) D AI3

 Q

AI3 ;

 Q:$G(LREND)  N LRCAN

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Need to pass "MI" to AI3SET

 NEW TMP

 ;----- END IHS MODIFICATIONS LR*5.2*1019

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ;S LRSSN=$P(PNM,",")_SSN(1)

 S LRSSN=$P(PNM,",")_HRCN  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 F LRIDT=0:0 S LRIDT=$O(^LRO(69,"AN",LROC,LRDFN,LRIDT)) Q:LRIDT<1  D

 . S LRND=$S($G(^LR(LRDFN,"CH",LRIDT,0)):^(0),$G(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"") D

 . . I $G(^LR(LRDFN,"CH",LRIDT,0)) D

 . . . I $O(^LR(LRDFN,"CH",LRIDT,1)),$P(LRND,U,3) D AI3SET Q  ; Print verified results.

 . . . I $O(^LR(LRDFN,"CH",LRIDT,1)) Q  ; Don't print unverified results.

 . . . S LRCAN=0 F  S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1  Q:($E(^(LRCAN,0))="*")

 . . . I $G(LRCAN) D AI3SET ; Print if cancel comment and no unverified results.

 . . ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019

 . . ;      There was a logic flaw that prevented any completed MICRO from appearing

 . . ;      on the nightly Interim report due to two factors:

 . . ;        (1) MICROs do not put Completed dates in $P(LRND,U,3) but in 

 . . ;            $P($G(^LR(LRDFN,"MI",LRIDT,1)),U,1) -- Date approved

 . . ;        (2) Physicians for MICROs are stored in $P(LRND,U,7), not $P(LRND,U,10)

 . . ; I $P($G(^LR(LRDFN,"MI",LRIDT,0)),U,3) D

 . . ; . S I=$O(^LR(LRDFN,"MI",LRIDT,0)) Q:I'=99  D AI3SET

 . . S TMP=""

 . . I $P($G(^LR(LRDFN,"MI",LRIDT,1)),U,1) S TMP="MI"  D AI3SET

 . . ;----- END IHS MODIFICATIONS LR*5.2*1019

 Q

AI3SET S LRPHY=$P($G(^VA(200,+$P(LRND,U,10),0)),U) S:LRPHY="" LRPHY="UNKNOWN"

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- "MI" Physician stored at different piece

 I $G(TMP)="MI" S LRPHY=$P($G(^VA(200,+$P(LRND,U,7),0)),U) S:LRPHY="" LRPHY="UNKNOWN"

 ;----- END IHS MODIFICATIONS LR*5.2*1019

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ;S ^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_SSN_U_AGE_U_SEX

 S ^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_HRCN_U_AGE_U_SEX  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 Q

CH ;Also used by DVBC Package

 Q:'$G(^LR(LRDFN,"CH",LRIDT,0))

 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021 -- Don't NEW the LROC var

 ; N LROC,LRCAN

 N LRCAN

 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021

 K ^TMP("LR",$J,"TP"),LRTP S LR0=^LR(LRDFN,"CH",LRIDT,0)

 Q:$O(^LR(LRDFN,"CH",LRIDT,1))&('$P(LR0,U,3))

 I '$P(LR0,U,3),$O(^LR(LRDFN,"CH",LRIDT,1,0)) D  Q:'$G(LRCAN)

 . S LRCAN=0 F  S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1  Q:$E($G(^(LRCAN,0)))="*"

 S LRCDT=+LR0,LRSS="CH",LROC=$P(LR0,U,11),LRAA="",LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5)

 D CH^LRRP

 Q

MI ;Also used by DVBC package

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019

 ; Double-check for "MI" data -- iff "CH" & "MI" have same LRDFN & LRIDT, it's

 ; possible that the "MI" data will not have been completed.

 ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021 -- Need to check nodes

 ; ;      1, 5, 8, 11, & 16 in Micro for dates (Thanks to WR at PIMC.)

 ; I $P($G(^LR(LRDFN,"MI",LRIDT,1)),U,1)="" Q  ; Data Approved

 NEW MITEST

 S MITEST="NO"

 F J=1,5,8,11,16  Q:MITEST="YES"  D

 . I $P($G(^LR(LRDFN,"MI",LRIDT,J)),U,1)'="" S MITEST="YES"

 I MITEST="NO" Q

 ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021

 ;

 ; It's silly to have EVERY command on one line.

 ; S LRCDT=9999999-LRIDT,^TMP("LR",$J,"TP",1)="^MI",^(1,LRCDT)="",^(LRCDT,-1)="",LRSS="MI",LRH=1 D:LRFOOT FOOT^LRRP1 Q:LRSTOP  D EN1^LRMIPC S LRHF=1,LRFOOT=0 K A,Z,LRH S:LREND LREND=0,LRSTOP=1

 S LRCDT=9999999-LRIDT

 S ^TMP("LR",$J,"TP",1)="^MI",^(1,LRCDT)="",^(LRCDT,-1)=""

 S LRSS="MI",LRH=1

 D:LRFOOT FOOT^LRRP1 Q:LRSTOP

 ;

 D EN1^LRMIPC

 ;

 S LRHF=1,LRFOOT=0

 K A,Z,LRH

 S:LREND LREND=0,LRSTOP=1

 ;----- END IHS MODIFICATIONS LR*5.2*1019

 Q

 ;

INIT D EN^LRPARAM

 S (LREND,LRSTOP,LRPG,LRFOOT)=0,LRCW=8,LRHF=1,(LRONESPC,LRONETST)=""

 K LRPLS

 Q

 ;

EN69 ;entry point for surgery pkg

 D START,^LRRK

 Q

GEN ;from LRGEN test overflow

 S LRLAB=$S($D(LRLABKY):1,1:0) D INIT,GENP,^LRRK

 Q

DS ;from LRRD, LRRS

 D INIT S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2) D SDQ

 Q

 ;

 ;

AIDQ ;tasked from LRTASK DAILY INTERIM,LRTASK CUM

 N LRLAB,LRH,LRWRDVEW,LRPRTPG

 S (LRH,LRWRDVEW)="",LRPRTPG=1

 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022

 ;  If a site wants, they can have their queued Interim reports

 ;  NOT print the address page, but IF and ONLY IF the BLR MASTER

 ;  CONTROL file's INTERIM REPORT ADDRESS PAGE field is set to NO. 

 I $P($G(^BLRSITE(+$G(DUZ(2)),3)),"^",4)="N" S LRPRTPG=0

 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022

 D AIDQUE

 K ^TMP($J)

 Q

 ;

 ;

DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING

 S:$D(ZTQUEUED) ZTREQ="@" D INIT S LRLAB=0,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX D CH D FOOT^LRRP1 D ^%ZISC

 Q

 ;

OR ;OE/RR entry point

 Q:'$D(ORVP)  S KILL=1 I '$D(LRPARAM) D EN^LRPARAM S KILL=0

 S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""

 D DT^LRX K DIC,LRTP S LRTP=0,DFN=+ORVP,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1

 D START,^LRRK

 I 'KILL K LRBLOOD,LRDT0,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE

 K KILL

 Q

 ;

 ;

PLSPG ;PRINT LAST PAGE WITH PERFORMING LAB SITE NAMES AND ADDRESSES -- EP

 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022

 ; If site DOES NOT want an address page, skip this

 ; I $P($G(^BLRSITE(+$G(DUZ(2)),3)),"^",4)="N" Q

 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022

 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1027

 ; I $$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")["N" Q

 I $$GET1^DIQ(9009029,+$G(DUZ(2)),"INTERIM REPORT ADDRESS PAGE","I")="N" Q   ; D LASTPAGE^LRRP1  IHS/MSC/MKK - LR*5.2*1038

 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1027

 ; W @IOF

 ; I $D(LRPG) D

 ; .S LRPG=LRPG+1

 ; .W !?65,"page ",LRPG

 ;W !,PNM,?30,SSN,?50,$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")

 ;----- BEGIN IHS MODIFICATION LR*5.2*1018

 ; W !,PNM,?30,$G(HRCN),?50,$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")

 ;----- END IHS MODIFICATIONS

 ; W !!,"PERFORMING LAB SITES"

 ; W !!!!

 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025

 NEW LASTPAGE

 W:($G(LRJ02))!($G(LRJ0))!($E(IOST,1,2)="C-") @IOF

 S LRHF=0,LRJ02=1

 I '$D(LRPG) S LRPG=0

 S LRPG=LRPG+1

 I $E(IOST,1)="P" D

 .W !!!!

 .S X="CLINICAL LABORATORY REPORT"

 .W ?(80-$L(X)\2),X,!

 I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV W !

 W "Printed at: ",?65,"page ",LRPG

 D LABHDR^BLRUTIL2

 W !,$E(PNM,1,38)

 W ?45,"Print date: ",$$UP^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"))

 ; W !!,"PERFORMING LAB SITES"

 W !!,"REFERRING LAB SITE(S)"  ; IHS/OIT/MKK - LR*5.2*1027

 W !!

 S LASTPAGE="YES"

 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025

 ;

 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022

SITELIST ; EP

 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022

 S LRPLS=0

 F  S LRPLS=$O(LRPLS(LRPLS)) Q:LRPLS=""  D

 .;W "[",LRPLS,"]  ",$$NAME^XUAF4(LRPLS),"     "

 .;S X=$$PADD^XUAF4(LRPLS)

 .;W $P(X,U),"     ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)

 .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 .I $T(NAME^XUAF4)]"",($T(PADD^XUAF4)]"") D

 ..; W "[",LRPLS,"]  ",$$NAME^XUAF4(LRPLS),"     "

 .. ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025

 ..; W "[",LRPLS,"]"

 .. W $$LJ^XLFSTR("["_LRPLS_"]",8)    ; IHS/MSC/MKK - LR*5.2*1038

 ..W ?7,$$NAME^XUAF4(LRPLS),"   "

 .. ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025

 ..S X=$$PADD^XUAF4(LRPLS)

 ..; W $P(X,U),"     ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)

 ..; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022

 ..;       Make sure no line wrapping occurs

 .. NEW COL,ADDRESS

 .. ; S ADDRESS=$P(X,U)_"     "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)

 .. ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025

 .. S ADDRESS=$P(X,U)_"   "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)

 .. ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025

 .. S COL=+$X

 .. I COL+$L(ADDRESS)>IOM W !,?10,ADDRESS

 .. I COL+$L(ADDRESS)<(IOM+1) W ADDRESS

 .;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022

 .;----- END IHS MODIFICATIONS

 .W !

 Q

 ;

 ; ----- Begin IHS/MSC/MKK - LR*5.2*1038

LASTFOOT ; EP 

 NEW LRIRAP

 ;

 S LRIRAP=$$GET1^DIQ(9009029,+$G(DUZ(2)),"INTERIM REPORT ADDRESS PAGE")

 Q:LRIRAP'="NO"

 ;

 NEW NUMSITES,WOTSITE

 S (NUMSITES,WOTSITE)=0

 F  S WOTSITE=$O(LRPLS(WOTSITE))  Q:WOTSITE=""  D

 . S NUMSITES=NUMSITES+1

 . I +$L($$NAME^XUAF4(WOTSITE))+$L($$PADD^XUAF4(WOTSITE))>IOM S NUMSITES=NUMSITES+1

 W !

 W:$Y'<(IOSL-(5+NUMSITES)) !

 F I=$Y:1:(IOSL-(5+NUMSITES)) W !           ; Get to "bottom" of the page

 D SITELIST                                 ; Print sites & addresses

 W !!,PNM,?30,"  HRCN:",HRCN,?54,LRDT0      ; IHS/MSC/MKK - LR*5.2*1039 - Print Name

 Q

 ; ----- Begin IHS/MSC/MKK - LR*5.2*1038

LRRP2     ;DALOI/OIT/RWF-INTERIM REPORT ; 01-Jun-2016 06:24 ; MKK

 +1       ;;5.2;LAB SERVICE;**1003,1018,1019,1021,1022,1025,1027,1038,1039**;NOV 01, 1997;Build 38

 +2       ;;5.2;LAB SERVICE;**106,121,221,283,300**;Sep 27, 1994

 +3       ;from option LRRP2

 +4       ;

BEGIN      DO INIT

           KILL DIC

           SET LRPRTPG=0

           DO ^LRDPA

           IF LRDFN>0

               DO START

           IF LRDFN<0

               GOTO END

           GOTO BEGIN

END        DO ^LRRK

 +1        QUIT 

CUM       ;ENTRY POINT FOR CUMULATIVE OPTIONS- LRAC PT,LRAC 1 PAGE, LRAC MANUAL

 +1        SET LRPRTPG=1

 +2       ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 +3       ; If the BLR MASTER CONTROL file's INTERIM REPORT ADDRESS field 

 +4       ; is set to NO, set flag.

 +5       ; I $P($G(^BLRSITE(+$G(DUZ(2)),3)),"^",4)="N" S LRPRTPG=0

 +6       ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 +7       ; 

 +8       ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 +9        IF $$GET1^DIQ(9009029,+$GET(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")["N"

               SET LRPRTPG=0

 +10      ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 +11      ; 

SUM       ;ENTRY POINT FROM SUM^LRACM2- PRINT A FULL PATIENT SUMMARY

 +1        DO INIT

           KILL DIC

           DO ^LRDPA

           IF LRDFN>0

               DO START

           IF LRDFN<0

               GOTO END

 +2        QUIT 

START      IF $ORDER(^LR(LRDFN,0))=""

               WRITE !,"NO LAB DATA ON THIS PATIENT!",$CHAR(7)

               QUIT 

 +1        SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)

 +2        IF $DATA(LRCUM)

               SET LRIDT=0

               SET LREDT=9999999

 +3       IF '$TEST

               Begin DoDot:1

 +4                SET LREDT="T-7"

                   DO ^LRWU3

                   IF LREND

                       QUIT 

 +5                SET LRIDT=9999999-LRSDT

                   SET LREDT=9999999-LREDT

               End DoDot:1

 +6        IF LREND

               QUIT 

 +7       ;

ASKPG      IF '$GET(LRPRTPG)

               Begin DoDot:1

 +1       ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 +2       ; If INTERIM REPORT ADDRESS PAGE filed set, don't ask Question

 +3                NEW IRPTADDP

 +4                SET IRPTADDP=$$GET1^DIQ(9009029,+$GET(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")

 +5                IF IRPTADDP["N"

                       SET LRPRTPG=0

                       QUIT 

 +6                IF IRPTADDP["Y"

                       SET LRPRTPG=1

                       QUIT 

 +7       ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027

 +8       ; 

 +9                SET DIR(0)="Y"

                   SET DIR("A")="Print address page"

                   SET DIR("B")="NO"

                   SET LRPRTPG=0

 +10               DO ^DIR

                   KILL DIR

 +11               IF Y

                       SET LRPRTPG=1

               End DoDot:1

 +12       SET %ZIS="Q"

           SET ZTSAVE("DFN")=""

           SET ZTSAVE("LR*")=""

           SET ZTRTN="SDQ^LRRP2"

 +13       DO IO^LRWU

 +14       QUIT 

 +15      ;

 +16      ;

SDQ       ; dequeued

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           USE IO

           DO PT^LRX

 +2        FOR 

               SET LRCNIDT=+$ORDER(^LR(LRDFN,"CH",LRIDT))

               SET LRMNIDT=+$ORDER(^LR(LRDFN,"MI",LRIDT))

               IF 'LRCNIDT&'LRMNIDT

                   QUIT 

               DO SWITCH

               IF LREND!LRSTOP!(LRIDT>LREDT)

                   QUIT 

 +3       ; D FOOT^LRRP1

 +4        DO LASTFOOT

 +5       ; D:$G(LRPRTPG) PLSPG

 +6       ; IHS/MSC/MKK - LR*5.2*1038

           DO PLSPG

 +7        QUIT 

 +8       ;

SWITCH     IF LRCNIDT=LRMNIDT

               SET LRIDT=LRCNIDT

               IF LRIDT>LREDT

                   QUIT 

               DO CH

               DO MI

               QUIT 

 +1        IF 'LRMNIDT

               SET LRIDT=LRCNIDT

               IF LRIDT>LREDT

                   QUIT 

               DO CH

               QUIT 

 +2        IF 'LRCNIDT

               SET LRIDT=LRMNIDT

               IF LRIDT>LREDT

                   QUIT 

               DO MI

               QUIT 

 +3        IF LRCNIDT<LRMNIDT

               SET LRIDT=LRCNIDT

               IF LRIDT>LREDT

                   QUIT 

               DO CH

               QUIT 

 +4        SET LRIDT=LRMNIDT

           IF LRIDT>LREDT

               QUIT 

           DO MI

 +5        QUIT 

 +6       ;

GENP       WRITE !!,"Too many tests!  Will use alternate format.  May show extra tests.",!

 +1        SET LREDT="T-7"

           DO ^LRWU3

           IF LREND

               QUIT 

           SET LRSDT=9999999-LRSDT

           SET LREDT=9999999-LREDT

 +2        KILL ^TMP("LR",$JOB,"T"),LRORD,LRTSTS

           SET ZTSAVE("^TMP(""LR"",$J,")=""

           SET ZTSAVE("DFN")=""

           SET ZTRTN="GDQ^LRRP2"

           DO IO^LRWU

 +3        QUIT 

 +4       ;

GDQ       ;dequeued

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           USE IO

           DO PT^LRX

 +2        SET LRSUB=""

           FOR 

               SET LRSUB=$ORDER(^TMP("LR",$JOB,"TMP",LRSUB))

               IF LRSUB=""

                   QUIT 

               SET X=+$PIECE(LRSUB,";",2)

               SET ^TMP("LR",$JOB,"T",X)=""

 +3        SET LRIDT=LRSDT

           FOR 

               SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))

               IF LRIDT<1!(LRIDT>LREDT)

                   QUIT 

               DO GEN2

               IF LREND!LRSTOP

                   QUIT 

 +4        KILL ^TMP("LR",$JOB,"T"),^TMP("LR",$JOB,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT

 +5        QUIT 

 +6       ;

GEN2       SET LRTN=0

           FOR 

               SET LRTN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRTN))

               IF LRTN<1

                   QUIT 

               IF $DATA(^TMP("LR",$JOB,"T",LRTN))

                   DO CH

                   QUIT 

 +1        IF '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)

               IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))

                   Begin DoDot:1

 +2                    SET LRCAN=0

                       FOR 

                           SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))

                           IF LRCAN<1

                               QUIT 

                           IF $EXTRACT($GET(^(LRCAN,0)))="*"

                               QUIT 

                   End DoDot:1

                   IF '$GET(LRCAN)

                       QUIT 

                   DO CH

 +3        QUIT 

 +4       ;

 +5       ;

AIDQUE    ;

 +1        DO INIT

 +2        SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)

 +3        KILL ^TMP($JOB)

 +4        SET LROCE=$SELECT($DATA(LROC):LROC,1:"")

           SET LROC=$SELECT(LROCE="":$ORDER(^LAB(64.6,"AI","")),1:LROC)

 +5        IF LROC'=""

               DO AI2

 +6        FOR 

               SET LROC=$ORDER(^LAB(64.6,"AI",LROC))

               IF LROC=""!($LENGTH(LROCE)&(LROC'=LROCE))

                   QUIT 

               DO AI2

 +7        SET LROC="UNKNOWN"

           DO AI2

 +8       ;

PRT       ; Print sorted data

 +1       ;U IO K VA D KVAR^VADPT S LREND=0

 +2       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +3       ;U IO K VA D KVAR^BLRDPT S LREND=0  ;IHS/OIRM TUC/MJL

 +4        USE IO

           KILL VA

           DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

           SET LREND=0

 +5       ;----- END IHS MODIFICATIONS

 +6        IF $ORDER(^TMP($JOB,0))=""

               Begin DoDot:1

 +7                WRITE !!?10,"No Interim report Patients to Print "

 +8                WRITE !?20,$$HTE^XLFDT($HOROLOG),!!

 +9                DO QUIT

               End DoDot:1

               QUIT 

 +10       SET LROC=""

 +11       FOR 

               SET LROC=$ORDER(^TMP($JOB,LROC))

               IF LROC=""!($GET(LREND))

                   QUIT 

               Begin DoDot:1

 +12               SET LRPHY=""

 +13               FOR 

                       SET LRPHY=$ORDER(^TMP($JOB,LROC,LRPHY))

                       IF LRPHY=""!($GET(LREND))

                           QUIT 

                       Begin DoDot:2

 +14                       SET LRSSN=""

 +15                       FOR 

                               SET LRSSN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN))

                               IF LRSSN=""!($GET(LREND))

                                   QUIT 

                               Begin DoDot:3

 +16                               SET LRDFN=0

 +17                               FOR 

                                       SET LRHF=1

                                       SET LRDFN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN))

                                       IF LRDFN<1!($GET(LREND))

                                           QUIT 

                                       Begin DoDot:4

 +18                                       SET LRIDT=0

 +19                                       FOR 

                                               SET LRIDT=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT))

                                               IF LRIDT<1!($GET(LREND))

                                                   QUIT 

                                               Begin DoDot:5

 +20                                               SET LRSS=""

                                                   SET PNM=^(LRIDT)

                                                   SET SSN=$PIECE(PNM,U,2)

                                                   SET AGE=$PIECE(PNM,U,3)

                                                   SET SEX=$PIECE(PNM,U,4)

                                                   SET PNM=$PIECE(PNM,U)

                                                   SET LRFOOT=0

 +21      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +22      ;IHS/ANMC/CLS 08/18/96

                                                   SET LRSS=""

                                                   SET PNM=^(LRIDT)

                                                   SET HRCN=$PIECE(PNM,U,2)

                                                   SET AGE=$PIECE(PNM,U,3)

                                                   SET SEX=$PIECE(PNM,U,4)

                                                   SET PNM=$PIECE(PNM,U)

                                                   SET LRFOOT=0

 +23      ;----- END IHS MODIFICATIONS

 +24                                               IF $DATA(^LR(LRDFN,"CH",LRIDT,0))#2

                                                       DO CH

 +25                                               SET LRFOOT=0

 +26                                               IF $DATA(^LR(LRDFN,"MI",LRIDT,0))#2

                                                       Begin DoDot:6

 +27                                                       IF $GET(LRSS)="CH"

                                                               DO FOOT^LRRP1

                                                               IF $GET(LRPRTPG)

                                                                   DO PLSPG

 +28                                                       DO MI

                                                       End DoDot:6

 +29      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Don't use FOOT^LRRP1 in the loop

 +30      ; I $G(LRSS)="CH" D FOOT^LRRP1 D:$G(LRPRTPG) PLSPG

 +31                                               IF $GET(LRSS)="CH"

                                                       IF $GET(LRPRTPG)

                                                           DO PLSPG

 +32      ;----- END IHS MODIFICATIONS LR*5.2*1022

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +33       DO FOOT^LRRP1

 +34       DO QUIT

 +35       QUIT 

 +36      ;

 +37      ;

QUIT      ;

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        DO ^%ZISC

           DO ^LRRK

 +3        QUIT 

 +4       ;

 +5       ;

AI2       ;

 +1        IF '$LENGTH($GET(LROC))

               QUIT 

 +2        FOR LRDFN=0:0

               SET LRDFN=$ORDER(^LRO(69,"AN",LROC,LRDFN))

               IF LRDFN<1

                   QUIT 

               IF $DATA(^LR(LRDFN,0))#2