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
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
Begin DoDot:1
+3 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
IF LREND
QUIT
+4 IF '$GET(VAERR)
DO AI3
End DoDot:1
+5 QUIT
AI3 ;
+1 IF $GET(LREND)
QUIT
NEW LRCAN
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Need to pass "MI" to AI3SET
+3 NEW TMP
+4 ;----- END IHS MODIFICATIONS LR*5.2*1019
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+6 ;S LRSSN=$P(PNM,",")_SSN(1)
+7 ;IHS/ANMC/CLS 08/18/96
SET LRSSN=$PIECE(PNM,",")_HRCN
+8 ;----- END IHS MODIFICATIONS
+9 FOR LRIDT=0:0
SET LRIDT=$ORDER(^LRO(69,"AN",LROC,LRDFN,LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:1
+10 SET LRND=$SELECT($GET(^LR(LRDFN,"CH",LRIDT,0)):^(0),$GET(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"")
Begin DoDot:2
+11 IF $GET(^LR(LRDFN,"CH",LRIDT,0))
Begin DoDot:3
+12 ; Print verified results.
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))
IF $PIECE(LRND,U,3)
DO AI3SET
QUIT
+13 ; Don't print unverified results.
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))
QUIT
+14 SET LRCAN=0
FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
IF LRCAN<1
QUIT
IF ($EXTRACT(^(LRCAN,0))="*")
QUIT
+15 ; Print if cancel comment and no unverified results.
IF $GET(LRCAN)
DO AI3SET
End DoDot:3
+16 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019
+17 ; There was a logic flaw that prevented any completed MICRO from appearing
+18 ; on the nightly Interim report due to two factors:
+19 ; (1) MICROs do not put Completed dates in $P(LRND,U,3) but in
+20 ; $P($G(^LR(LRDFN,"MI",LRIDT,1)),U,1) -- Date approved
+21 ; (2) Physicians for MICROs are stored in $P(LRND,U,7), not $P(LRND,U,10)
+22 ; I $P($G(^LR(LRDFN,"MI",LRIDT,0)),U,3) D
+23 ; . S I=$O(^LR(LRDFN,"MI",LRIDT,0)) Q:I'=99 D AI3SET
+24 SET TMP=""
+25 IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,1)),U,1)
SET TMP="MI"
DO AI3SET
+26 ;----- END IHS MODIFICATIONS LR*5.2*1019
End DoDot:2
End DoDot:1
+27 QUIT
AI3SET SET LRPHY=$PIECE($GET(^VA(200,+$PIECE(LRND,U,10),0)),U)
IF LRPHY=""
SET LRPHY="UNKNOWN"
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- "MI" Physician stored at different piece
+2 IF $GET(TMP)="MI"
SET LRPHY=$PIECE($GET(^VA(200,+$PIECE(LRND,U,7),0)),U)
IF LRPHY=""
SET LRPHY="UNKNOWN"
+3 ;----- END IHS MODIFICATIONS LR*5.2*1019
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 ;S ^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_SSN_U_AGE_U_SEX
+6 ;IHS/ANMC/CLS 08/18/96
SET ^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_HRCN_U_AGE_U_SEX
+7 ;----- END IHS MODIFICATIONS
+8 QUIT
CH ;Also used by DVBC Package
+1 IF '$GET(^LR(LRDFN,"CH",LRIDT,0))
QUIT
+2 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021 -- Don't NEW the LROC var
+3 ; N LROC,LRCAN
+4 NEW LRCAN
+5 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+6 KILL ^TMP("LR",$JOB,"TP"),LRTP
SET LR0=^LR(LRDFN,"CH",LRIDT,0)
+7 IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))&('$PIECE(LR0,U,3))
QUIT
+8 IF '$PIECE(LR0,U,3)
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))
Begin DoDot:1
+9 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
+10 SET LRCDT=+LR0
SET LRSS="CH"
SET LROC=$PIECE(LR0,U,11)
SET LRAA=""
SET LRAAO=1
SET LRTC=0
SET LRSPEC=$PIECE(LR0,U,5)
+11 DO CH^LRRP
+12 QUIT
MI ;Also used by DVBC package
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019
+2 ; Double-check for "MI" data -- iff "CH" & "MI" have same LRDFN & LRIDT, it's
+3 ; possible that the "MI" data will not have been completed.
+4 ; ----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021 -- Need to check nodes
+5 ; ; 1, 5, 8, 11, & 16 in Micro for dates (Thanks to WR at PIMC.)
+6 ; I $P($G(^LR(LRDFN,"MI",LRIDT,1)),U,1)="" Q ; Data Approved
+7 NEW MITEST
+8 SET MITEST="NO"
+9 FOR J=1,5,8,11,16
IF MITEST="YES"
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,J)),U,1)'=""
SET MITEST="YES"
End DoDot:1
+11 IF MITEST="NO"
QUIT
+12 ; ----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+13 ;
+14 ; It's silly to have EVERY command on one line.
+15 ; 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
+16 SET LRCDT=9999999-LRIDT
+17 SET ^TMP("LR",$JOB,"TP",1)="^MI"
SET ^(1,LRCDT)=""
SET ^(LRCDT,-1)=""
+18 SET LRSS="MI"
SET LRH=1
+19 IF LRFOOT
DO FOOT^LRRP1
IF LRSTOP
QUIT
+20 ;
+21 DO EN1^LRMIPC
+22 ;
+23 SET LRHF=1
SET LRFOOT=0
+24 KILL A,Z,LRH
+25 IF LREND
SET LREND=0
SET LRSTOP=1
+26 ;----- END IHS MODIFICATIONS LR*5.2*1019
+27 QUIT
+28 ;
INIT DO EN^LRPARAM
+1 SET (LREND,LRSTOP,LRPG,LRFOOT)=0
SET LRCW=8
SET LRHF=1
SET (LRONESPC,LRONETST)=""
+2 KILL LRPLS
+3 QUIT
+4 ;
EN69 ;entry point for surgery pkg
+1 DO START
DO ^LRRK
+2 QUIT
GEN ;from LRGEN test overflow
+1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
DO INIT
DO GENP
DO ^LRRK
+2 QUIT
DS ;from LRRD, LRRS
+1 DO INIT
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=$PIECE(^(0),U,2)
DO SDQ
+2 QUIT
+3 ;
+4 ;
AIDQ ;tasked from LRTASK DAILY INTERIM,LRTASK CUM
+1 NEW LRLAB,LRH,LRWRDVEW,LRPRTPG
+2 SET (LRH,LRWRDVEW)=""
SET LRPRTPG=1
+3 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
+4 ; If a site wants, they can have their queued Interim reports
+5 ; NOT print the address page, but IF and ONLY IF the BLR MASTER
+6 ; CONTROL file's INTERIM REPORT ADDRESS PAGE field is set to NO.
+7 IF $PIECE($GET(^BLRSITE(+$GET(DUZ(2)),3)),"^",4)="N"
SET LRPRTPG=0
+8 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
+9 DO AIDQUE
+10 KILL ^TMP($JOB)
+11 QUIT
+12 ;
+13 ;
DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
DO INIT
SET LRLAB=0
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
DO CH
DO FOOT^LRRP1
DO ^%ZISC
+2 QUIT
+3 ;
OR ;OE/RR entry point
+1 IF '$DATA(ORVP)
QUIT
SET KILL=1
IF '$DATA(LRPARAM)
DO EN^LRPARAM
SET KILL=0
+2 SET (LREND,LRSTOP)=0
SET LRCW=8
SET LRHF=1
SET LRFOOT=0
SET (LRONESPC,LRONETST)=""
+3 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET DFN=+ORVP
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
IF LRDFN<1
QUIT
+4 DO START
DO ^LRRK
+5 IF 'KILL
KILL LRBLOOD,LRDT0,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE
+6 KILL KILL
+7 QUIT
+8 ;
+9 ;
PLSPG ;PRINT LAST PAGE WITH PERFORMING LAB SITE NAMES AND ADDRESSES -- EP
+1 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
+2 ; If site DOES NOT want an address page, skip this
+3 ; I $P($G(^BLRSITE(+$G(DUZ(2)),3)),"^",4)="N" Q
+4 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
+5 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1027
+6 ; I $$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT ADDRESS PAGE")["N" Q
+7 ; D LASTPAGE^LRRP1 IHS/MSC/MKK - LR*5.2*1038
IF $$GET1^DIQ(9009029,+$GET(DUZ(2)),"INTERIM REPORT ADDRESS PAGE","I")="N"
QUIT
+8 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1027
+9 ; W @IOF
+10 ; I $D(LRPG) D
+11 ; .S LRPG=LRPG+1
+12 ; .W !?65,"page ",LRPG
+13 ;W !,PNM,?30,SSN,?50,$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")
+14 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+15 ; W !,PNM,?30,$G(HRCN),?50,$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")
+16 ;----- END IHS MODIFICATIONS
+17 ; W !!,"PERFORMING LAB SITES"
+18 ; W !!!!
+19 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+20 NEW LASTPAGE
+21 IF ($GET(LRJ02))!($GET(LRJ0))!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+22 SET LRHF=0
SET LRJ02=1
+23 IF '$DATA(LRPG)
SET LRPG=0
+24 SET LRPG=LRPG+1
+25 IF $EXTRACT(IOST,1)="P"
Begin DoDot:1
+26 WRITE !!!!
+27 SET X="CLINICAL LABORATORY REPORT"
+28 WRITE ?(80-$LENGTH(X)\2),X,!
End DoDot:1
+29 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
DO ^LRAIPRIV
WRITE !
+30 WRITE "Printed at: ",?65,"page ",LRPG
+31 DO LABHDR^BLRUTIL2
+32 WRITE !,$EXTRACT(PNM,1,38)
+33 WRITE ?45,"Print date: ",$$UP^XLFSTR($$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"))
+34 ; W !!,"PERFORMING LAB SITES"
+35 ; IHS/OIT/MKK - LR*5.2*1027
WRITE !!,"REFERRING LAB SITE(S)"
+36 WRITE !!
+37 SET LASTPAGE="YES"
+38 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+39 ;
+40 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
SITELIST ; EP
+1 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
+2 SET LRPLS=0
+3 FOR
SET LRPLS=$ORDER(LRPLS(LRPLS))
IF LRPLS=""
QUIT
Begin DoDot:1
+4 ;W "[",LRPLS,"] ",$$NAME^XUAF4(LRPLS)," "
+5 ;S X=$$PADD^XUAF4(LRPLS)
+6 ;W $P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
+7 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+8 IF $TEXT(NAME^XUAF4)]""
IF ($TEXT(PADD^XUAF4)]"")
Begin DoDot:2
+9 ; W "[",LRPLS,"] ",$$NAME^XUAF4(LRPLS)," "
+10 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+11 ; W "[",LRPLS,"]"
+12 ; IHS/MSC/MKK - LR*5.2*1038
WRITE $$LJ^XLFSTR("["_LRPLS_"]",8)
+13 WRITE ?7,$$NAME^XUAF4(LRPLS)," "
+14 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+15 SET X=$$PADD^XUAF4(LRPLS)
+16 ; W $P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
+17 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
+18 ; Make sure no line wrapping occurs
+19 NEW COL,ADDRESS
+20 ; S ADDRESS=$P(X,U)_" "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
+21 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+22 SET ADDRESS=$PIECE(X,U)_" "_$PIECE(X,U,2)_", "_$PIECE(X,U,3)_" "_$PIECE(X,U,4)
+23 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+24 SET COL=+$X
+25 IF COL+$LENGTH(ADDRESS)>IOM
WRITE !,?10,ADDRESS
+26 IF COL+$LENGTH(ADDRESS)<(IOM+1)
WRITE ADDRESS
End DoDot:2
+27 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
+28 ;----- END IHS MODIFICATIONS
+29 WRITE !
End DoDot:1
+30 QUIT
+31 ;
+32 ; ----- Begin IHS/MSC/MKK - LR*5.2*1038
+1 NEW LRIRAP
+2 ;
+3 SET LRIRAP=$$GET1^DIQ(9009029,+$GET(DUZ(2)),"INTERIM REPORT ADDRESS PAGE")
+4 IF LRIRAP'="NO"
QUIT
+5 ;
+6 NEW NUMSITES,WOTSITE
+7 SET (NUMSITES,WOTSITE)=0
+8 FOR
SET WOTSITE=$ORDER(LRPLS(WOTSITE))
IF WOTSITE=""
QUIT
Begin DoDot:1
+9 SET NUMSITES=NUMSITES+1
+10 IF +$LENGTH($$NAME^XUAF4(WOTSITE))+$LENGTH($$PADD^XUAF4(WOTSITE))>IOM
SET NUMSITES=NUMSITES+1
End DoDot:1
+11 WRITE !
+12 IF $Y'<(IOSL-(5+NUMSITES))
WRITE !
+13 ; Get to "bottom" of the page
FOR I=$Y:1:(IOSL-(5+NUMSITES))
WRITE !
+14 ; Print sites & addresses
DO SITELIST
+15 ; IHS/MSC/MKK - LR*5.2*1039 - Print Name
WRITE !!,PNM,?30," HRCN:",HRCN,?54,LRDT0
+16 QUIT
+17 ; ----- Begin IHS/MSC/MKK - LR*5.2*1038
