LRRP1 ;DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1004,1013,1016,153,221,283,1018,1025,1026,286,1027,1028,1030,1031,1033,1038,1039,1041**;NOV 01, 1997;Build 23
;
;from LRRP, LRRP2, LRRP3
;
PRINT S:'$L($G(SEX)) SEX="M" S:'$L($G(DOB)) DOB="UNKNOWN"
S LRAAO=0 F S LRAAO=$O(^TMP("LR",$J,"TP",LRAAO)) Q:LRAAO<1 D ORDER Q:LRSTOP
K ^TMP("LR",$J,"TP")
Q
;
;
ORDER N LRCAN
S LRCDT=0
F S LRCDT=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT)) Q:LRCDT<1 D
. S LRCAN=0
. I LRSS="CH" D
. . S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
. . F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:$E($G(^(LRCAN,0)))="*"
. D TEST Q:LRSTOP
Q
;
;
TEST ; EP -- IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
S LRSS=$P(^TMP("LR",$J,"TP",LRAAO),U,2)
S LR0=$S($D(^(LRAAO,LRCDT))#2:^(LRCDT),1:""),LRTC=$P(LR0,U,12)
I LRSS="MI" D Q
. S LRH=1 D:LRFOOT FOOT Q:LRSTOP
. D EN1^LRMIPC
. S LRHF=1,LRFOOT=0
. K A,Z,LRH
. S:LREND LREND=0,LRSTOP=1
;
Q:'$G(LRCAN)&('$P(LR0,U,3)) D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP
;
I $P(XQY0,U)="LRRS"!($P(XQY0,U)="BLR LRRD BY MD")!($P(XQY0,U)="LRRS BY LOC")!($P(XQY0,U)="LRRD")!($P(XQY0,U)="LRRP2") D
. I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAU
;
S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
;
D ORU ; Accession info
;
W !,?5,"Provider: ",LRDOC
; D:'$G(BLRGUI) ESIGINFO^BLRUTIL3
; D:'$G(BLRGUI) ESIGINFO^BLRUTIL5 ; IHS/MSC/MKK - LR*5.2*1033
D ARRIVETM^BLRUTIL8(LRDFN,LRSS,LRIDT) ; IHS/MSC/MKK - LR*5.2*1039 - Print Arrival Time
; W !,?5,"Specimen:",$E($P(^LAB(61,LRSPEC,0),U),1,23)
W !,?5,"Specimen:",$E($P($G(^LAB(61,LRSPEC,0)),U),1,23) ; Naked Ref fix - IHS/OIT/MKK - LR*5.2*1031
W ?42,"Spec Collect Date/Time:",$$FMTE^XLFDT(LRCDT,"2MZ")
;
D CONDSPEC^BLRLRRP1 ; IHS/MSC/MKK - LR*5.2*1033
;
D COLHEADS
;
S LRPO=0
F S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0 S LRDATA=^(LRPO) D DATA Q:LRSTOP
Q:LRSTOP
;
I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
. W !,"Comment: " S LRCMNT=0
. F S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1 D Q:LRSTOP
. . W ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)
. . D CONT Q:LRSTOP
. . W:$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) !?9
Q:LRSTOP
D BOTTOMPG
Q
;
COLHEADS ; EP - IHS/OIT/MKK - LR*5.2*1027
; W !!,"Test name"
; W ?19,"Result units"
W !,?25,"Res",!
W "Test name"
W ?18,"Result"
W ?25,"Flg"
W ?29,"units"
W ?43,"Ref. range"
W ?60,"Site"
W ?66,"Result Dt/Time"
Q
;
BOTTOMPG ; EP - IHS/OIT/MKK - LR*5.2*1027
NEW STR
NEW IOM ; IHS/MSC/MKK - LR*5.2*1038
S IOM=80 ; IHS/MSC/MKK - LR*5.2*1038
;
W !,$TR($J("",IOM)," ","=")
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
; S STR="KEY: A=Abnormal L=Abnormal Low H=Abnormal High"
; W !,$$CJ^XLFSTR(STR,IOM)
; S STR="*=Critical value TR=Therapeutic Range"
; W !,$$CJ^XLFSTR(STR,IOM)
; ----- END IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 - Make one line
; Make one line
W !,"KEY: A=Abnormal L=Abnormal Low H=Abnormal High *=Critical TR=Therapeutic",!
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
S LRFOOT=1
Q
; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
;
;
DATA ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified DATA code
N LR63DATA
;
S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
S X=$P(LRDATA,U,7) Q:X=""
S LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$P(LRDATA,U,10),LRTSTS)
;
S LRLO=$P(LR63DATA,"^",3),LRHI=$P(LR63DATA,"^",4),LRREFS=$$EN^LRLRRVF(LRLO,LRHI),LRPLS=$P(LR63DATA,"^",6),LRTHER=$P(LR63DATA,"^",7)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
S:$E(LRREFS,1,7)="Ref: <=" LRREFS=$TR(LRREFS,"=")
S:$E(LRREFS,1,7)="Ref: >=" LRREFS=$TR(LRREFS,"=")
; ----- END IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
;
I LRPLS S LRPLS(LRPLS)=LRPLS
;
W !,$S($L($P(LRDATA,U,2))>15:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
S X=$P(LR63DATA,"^")
; W ?16,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)
W ?16,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)
W ?26,$P(LR63DATA,"^",2)
; W ?26,$S($P(LR63DATA,"^",2)="N":"",1:$P(LR63DATA,"^",2))
W ?29,$P(LR63DATA,"^",5)
I $G(LRREFS)["$S(" D MUMPRNGE(.LRREFS)
; W ?43,$E(LRREFS,1,15) K LRREFS
; W ?55,$S(LRTHER:"(TR)",1:"")
;
; I LRPLS'="" W ?59,$J("["_LRPLS_"]",6)
; W ?66,$$GETCOMPD^BLRUTIL4 ; IHS/MSC/MKK - LR*5.2*1031
D LRREFS^BLRLRRP1 ; IHS/MSC/MKK - LR*5.2*1033
;
D CONT Q:LRSTOP
;
I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D Q:LRSTOP
. S LRINTP=0
. F S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1 W !?7,"Eval: ",^(LRINTP) D CONT Q:LRSTOP
;
Q
;
;
MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
NEW LOW,HIGH,RV1,RV2
;
; IHS/OIT/MKK - LR*5.2*1031 Note:
; If there is only one (1) Reference Range for a test, the LRLRRVF routine returns the Single Ref Range
; with "Ref: " prefixed to it. (See DATA+6 above.) However, that Ref Range could have a $SELECT statement,
; which means it gets passed to this subroutine. At this point, the RANGE variable must be a valid Mumps
; string, with no prefix. The 1031 changes below will try to ensure that.
;
S LOW=$$TRIM^XLFSTR($P(RANGE,"-"),"LR"," ")
S:$E(LOW,1,4)="Ref:" LOW=$P(LOW," ",2,999) ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
;
S HIGH=$$TRIM^XLFSTR($P(RANGE,"-",2),"LR"," ")
S:$E(HIGH,1,4)="Ref:" HIGH=$P(HIGH," ",2,999) ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
;
I $G(LOW)=""&($G(HIGH)="") S RANGE=" " Q
;
S RV1=$$MUMPEVAL(LOW)
S RV2=$$MUMPEVAL(HIGH)
;
S RANGE=$$EN^LRLRRVF(RV1,RV2)
;
; I $G(RV1)=""&($G(RV2)="") S RANGE=" " Q
;
; S RANGE=RV1_" - "_RV2
Q
;
MUMPEVAL(EVAL) ; EP
NEW STR,WOT
;
; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
; reference range code has been mis-parsed. Return NULL.
I EVAL'["$S(" D Q EVAL
. I EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&") S EVAL=""
;
; If there is an "(" in the string, but no ")", that means the reference range code is too complex
; and/or has been mis-parsed. Return NULL.
I EVAL'[")" Q ""
;
S STR="WOT="_EVAL
S @STR
;
; ANY punctuation in string means parsing failed. Return NULL.
I WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&") S WOT=""
;
Q WOT
;
CHECK I LRTC+11>(IOSL-$Y) D FOOT Q:LRSTOP D HDR
Q
;
CONT ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
; Q:($Y+5)<IOSL
Q:($Y+9)<IOSL ; IHS/MSC/MKK - LR*5.2*1038
;
D BOTTOMPG
D FOOT
Q:LRSTOP
;
D HDR
W !!,$$CJ^XLFSTR(">> CONTINUATION OF "_$P(LR0,U,6)_" <<",IOM)
D COLHEADS
Q
; End IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
;
;
; From LRRP, LRRP2, LRRP3
Q:LRSTOP ; If stop, then quit
Q:+$G(LREND)!(+$G(LRIDT)>+$G(LREDT)) ; Double check to stop -- IHS/OIT/MKK - LR*5.2*1030
;
NEW LRIRAP,WOTERR
;
S LRIRAP=$$GET1^DIQ(9009029,+$G(DUZ(2)),"INTERIM REPORT ADDRESS PAGE",,,"WOTERR")
I $G(LRIRAP)="NO"!($G(LRIRAP)="") D
. 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^LRRP2 ; Print sites & addresses
;
; Check again due to TRUE issues with the ELSE statement.
I $G(LRIRAP)="YES" F I=$Y:1:(IOSL-4) W ! ; "Go to" bottom of the page
I $G(LRIRAP)="YES" F I=$Y:1:(IOSL-5) W ! ; LR*5.2*1038 - "Go to" bottom of the page
;
I $E(IOST,1,2)'="C-" D Q
. NEW DONOTF ; DO NOT FILE flag
. S DONOTF=$$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT DO NOT FILE")
. I $G(DONOTF)["Y" W !,"INTERIM REPORT DO NOT FILE",?30,$E(PNM,1,23)," HRCN:",HRCN,?70,LRDT0,!
. I $G(DONOTF)'["Y" W PNM," HRCN:",HRCN,?70,LRDT0,!
;
; W !,$E(PNM,1,23),?28,HRCN,?40,LRDT0
W !,PNM,?30," HRCN:",HRCN,?46,LRDT0 ; IHS/MSC/MKK - LR*5.2*1038
R ?60,"PRESS '^' TO STOP ",X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LRSTOP=1
Q
; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified FOOT Code
;
HDR ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
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" W !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!
I $E(IOST)'="C" W !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",80),! ; IHS/MSC/MKK - LR*5.2*1038
I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV W !
; W "Printed at: ",?65,"page ",LRPG ; IHS/OIT/MKK - LR*5.2*1028
; W "Printed at: ",?65,"page ",LRPG,! ; IHS/OIT/MKK - LR*5.2*1039
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
D
. NEW PAGESTR,TAB
. S PAGESTR="page "_LRPG
. S TAB=(IOM-$L(PAGESTR))-2
. W "Printed at: ",?TAB,PAGESTR,!
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
D LABHDR^BLRUTIL2
W !,PNM,?45,"Date/Time Printed: ",$$FMTE^XLFDT($$NOW^XLFDT,"2MZ")
;
NEW AGE
I +$P($G(^LR(LRDFN,0)),"^",2)=2 S DOB=$$DOB^AUPNPAT(+$P($G(^LR(LRDFN,0)),"^",3)) ; GIMC Correction
I DOB>0 D
. S AGE=$$UP^XLFSTR($$DATE^LRDAGE(DOB)) ; Age as of Today
. S:AGE["YR" AGE=+AGE ; If Age in Years, get rid of "YR" string.
;
W !?5,"HRCN:",HRCN
; W ?25,"SEX:",SEX
; W ?35,"DOB:",$S(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
; W:+$G(AGE)>0 ?54,"CURRENT AGE:",AGE
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
W ?20,"SEX:",SEX
W ?27,"DOB:",$S(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
; W:+$G(AGE)>0 ?45,"CURRENT AGE:",AGE
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
NEW DOD
; S DOD=+$$GET1^DIQ(2,DFN,.351,"I") ; Date of Death
S DOD=+$$GET1^DIQ(+$G(LRDPF),DFN,.351,"I") ; IHS/MSC/MKK - LR*5.2*1041
; W:'DOD&(AGE) ?45,"CURRENT AGE:",AGE
W:'DOD&(AGE)&('$$GET^XPAR("ALL","BLR DOB ONLY",1,"Q")) ?45,"CURRENT AGE:",AGE ; IHS/MSC/MKK - LR*5.2*1041
W:DOD ?45,"DIED:",$$FMTE^XLFDT(DOD,"D")
; ----- END IHS/MSC/MKK - LR*5.2*1033
NEW LOCIEN,LOCDESC
S LOCIEN=+$P($P(LR0,"^",13),";")
S LOCDESC=$P($G(^SC(LOCIEN,0)),"^")
; W:$L(LOCDESC)<1!($L(LOCDESC)>14) ?62,"LOC:",LROC
; W:$L(LOCDESC)>0&($L(LOCDESC)<15) ?62,"LOC:",LOCDESC
; ----- END IHS/OIT/MKK - LR*5.2*1030
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
W:$L(LOCDESC)<1!($L(LOCDESC)>12) ?64,"LOC:",$E(LROC,1,12)
W:$L(LOCDESC)>0&($L(LOCDESC)<12) ?64,"LOC:",LOCDESC
; ----- END IHS/MSC/MKK - LR*5.2*1031
Q
; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
;
ORU ; Display remote ordering info if available
N LRX,IENS
; S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU")),IENS=LRIDT_","_LRDFN_","
; D EN^DDIOL("Accession [UID]: "_$P(LR0,"^",6)_" ["_$P(LRX,"^")_"]","","!")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
NEW LRZERO
S LRZERO=$G(^LR(LRDFN,LRSS,LRIDT,0)),LRX=$G(^("ORU")),IENS=LRIDT_","_LRDFN_","
D:$L(LRX) EN^DDIOL("Accession [UID]: "_$P(LRZERO,U,6)_" ["_$P(LRX,U)_"]")
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
I $P(LRX,"^",3) D
. D EN^DDIOL("Ordering Site: "_$$GET1^DIQ(63.04,IENS,.33,""),"","!?2")
. D EN^DDIOL(" Ordering Site UID: "_$P(LRX,"^",5),"","?43")
I $P(LRX,"^",2) D EN^DDIOL("Collecting Site: "_$$GET1^DIQ(63.04,IENS,.32,""),"","!")
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
LASTPAGE ; EP - Last Page
NEW CNT,HNOW,I
S (CNT,I)=0 F S I=$O(LRPLS(I)) Q:I="" S CNT=CNT+1
S CNT=CNT+1
I $E(IOST,1,2)="C-" F I=$Y:1:((IOSL-6)-CNT) W !
E W !!
D SITELIST^LRRP2
W !!,PNM,?30," HRCN:",HRCN,?54,LRDT0
Q
; ----- END IHS/MSC/MKK - LR*5.2*1038
LRRP1 ;DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1004,1013,1016,153,221,283,1018,1025,1026,286,1027,1028,1030,1031,1033,1038,1039,1041**;NOV 01, 1997;Build 23
+2 ;
+3 ;from LRRP, LRRP2, LRRP3
+4 ;
PRINT IF '$LENGTH($GET(SEX))
SET SEX="M"
IF '$LENGTH($GET(DOB))
SET DOB="UNKNOWN"
+1 SET LRAAO=0
FOR
SET LRAAO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO))
IF LRAAO<1
QUIT
DO ORDER
IF LRSTOP
QUIT
+2 KILL ^TMP("LR",$JOB,"TP")
+3 QUIT
+4 ;
+5 ;
ORDER NEW LRCAN
+1 SET LRCDT=0
+2 FOR
SET LRCDT=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT))
IF LRCDT<1
QUIT
Begin DoDot:1
+3 SET LRCAN=0
+4 IF LRSS="CH"
Begin DoDot:2
+5 SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)
+6 FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
IF LRCAN<1
QUIT
IF $EXTRACT($GET(^(LRCAN,0)))="*"
QUIT
End DoDot:2
+7 DO TEST
IF LRSTOP
QUIT
End DoDot:1
+8 QUIT
+9 ;
+10 ;
TEST ; EP -- IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
+1 SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)
+2 SET LRSS=$PIECE(^TMP("LR",$JOB,"TP",LRAAO),U,2)
+3 SET LR0=$SELECT($DATA(^(LRAAO,LRCDT))#2:^(LRCDT),1:"")
SET LRTC=$PIECE(LR0,U,12)
+4 IF LRSS="MI"
Begin DoDot:1
+5 SET LRH=1
IF LRFOOT
DO FOOT
IF LRSTOP
QUIT
+6 DO EN1^LRMIPC
+7 SET LRHF=1
SET LRFOOT=0
+8 KILL A,Z,LRH
+9 IF LREND
SET LREND=0
SET LRSTOP=1
End DoDot:1
QUIT
+10 ;
+11 IF '$GET(LRCAN)&('$PIECE(LR0,U,3))
QUIT
DO @$SELECT(LRHF:"HDR",1:"CHECK")
IF LRSTOP
QUIT
+12 ;
+13 IF $PIECE(XQY0,U)="LRRS"!($PIECE(XQY0,U)="BLR LRRD BY MD")!($PIECE(XQY0,U)="LRRS BY LOC")!($PIECE(XQY0,U)="LRRD")!($PIECE(XQY0,U)="LRRP2")
Begin DoDot:1
+14 IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
DO ^BLRALAU
End DoDot:1
+15 ;
+16 SET LRSPEC=+$PIECE(LR0,U,5)
SET X=$PIECE(LR0,U,10)
DO DOC^LRX
+17 ;
+18 ; Accession info
DO ORU
+19 ;
+20 WRITE !,?5,"Provider: ",LRDOC
+21 ; D:'$G(BLRGUI) ESIGINFO^BLRUTIL3
+22 ; D:'$G(BLRGUI) ESIGINFO^BLRUTIL5 ; IHS/MSC/MKK - LR*5.2*1033
+23 ; IHS/MSC/MKK - LR*5.2*1039 - Print Arrival Time
DO ARRIVETM^BLRUTIL8(LRDFN,LRSS,LRIDT)
+24 ; W !,?5,"Specimen:",$E($P(^LAB(61,LRSPEC,0),U),1,23)
+25 ; Naked Ref fix - IHS/OIT/MKK - LR*5.2*1031
WRITE !,?5,"Specimen:",$EXTRACT($PIECE($GET(^LAB(61,LRSPEC,0)),U),1,23)
+26 WRITE ?42,"Spec Collect Date/Time:",$$FMTE^XLFDT(LRCDT,"2MZ")
+27 ;
+28 ; IHS/MSC/MKK - LR*5.2*1033
DO CONDSPEC^BLRLRRP1
+29 ;
+30 DO COLHEADS
+31 ;
+32 SET LRPO=0
+33 FOR
SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
IF LRPO'>0
QUIT
SET LRDATA=^(LRPO)
DO DATA
IF LRSTOP
QUIT
+34 IF LRSTOP
QUIT
+35 ;
+36 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))
Begin DoDot:1
+37 WRITE !,"Comment: "
SET LRCMNT=0
+38 FOR
SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
IF LRCMNT<1
QUIT
Begin DoDot:2
+39 WRITE ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)
+40 DO CONT
IF LRSTOP
QUIT
+41 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
WRITE !?9
End DoDot:2
IF LRSTOP
QUIT
End DoDot:1
+42 IF LRSTOP
QUIT
+43 DO BOTTOMPG
+44 QUIT
+45 ;
COLHEADS ; EP - IHS/OIT/MKK - LR*5.2*1027
+1 ; W !!,"Test name"
+2 ; W ?19,"Result units"
+3 WRITE !,?25,"Res",!
+4 WRITE "Test name"
+5 WRITE ?18,"Result"
+6 WRITE ?25,"Flg"
+7 WRITE ?29,"units"
+8 WRITE ?43,"Ref. range"
+9 WRITE ?60,"Site"
+10 WRITE ?66,"Result Dt/Time"
+11 QUIT
+12 ;
BOTTOMPG ; EP - IHS/OIT/MKK - LR*5.2*1027
+1 NEW STR
+2 ; IHS/MSC/MKK - LR*5.2*1038
NEW IOM
+3 ; IHS/MSC/MKK - LR*5.2*1038
SET IOM=80
+4 ;
+5 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+6 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
+7 ; S STR="KEY: A=Abnormal L=Abnormal Low H=Abnormal High"
+8 ; W !,$$CJ^XLFSTR(STR,IOM)
+9 ; S STR="*=Critical value TR=Therapeutic Range"
+10 ; W !,$$CJ^XLFSTR(STR,IOM)
+11 ; ----- END IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 - Make one line
+14 ; Make one line
+15 WRITE !,"KEY: A=Abnormal L=Abnormal Low H=Abnormal High *=Critical TR=Therapeutic",!
+16 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+17 ;
+18 SET LRFOOT=1
+19 QUIT
+20 ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
+21 ;
+22 ;
DATA ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified DATA code
+1 NEW LR63DATA
+2 ;
+3 SET LRTSTS=+LRDATA
SET LRPC=$PIECE(LRDATA,U,5)
SET LRSUB=$PIECE(LRDATA,U,6)
+4 SET X=$PIECE(LRDATA,U,7)
IF X=""
QUIT
+5 SET LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$PIECE(LRDATA,U,10),LRTSTS)
+6 ;
+7 SET LRLO=$PIECE(LR63DATA,"^",3)
SET LRHI=$PIECE(LR63DATA,"^",4)
SET LRREFS=$$EN^LRLRRVF(LRLO,LRHI)
SET LRPLS=$PIECE(LR63DATA,"^",6)
SET LRTHER=$PIECE(LR63DATA,"^",7)
+8 ;
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
+10 IF $EXTRACT(LRREFS,1,7)="Ref
SET LRREFS=$TRANSLATE(LRREFS,"=")
+11 IF $EXTRACT(LRREFS,1,7)="Ref
SET LRREFS=$TRANSLATE(LRREFS,"=")
+12 ; ----- END IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
+13 ;
+14 IF LRPLS
SET LRPLS(LRPLS)=LRPLS
+15 ;
+16 WRITE !,$SELECT($LENGTH($PIECE(LRDATA,U,2))>15:$PIECE(LRDATA,U,3),1:$PIECE(LRDATA,U,2))
+17 SET X=$PIECE(LR63DATA,"^")
+18 ; W ?16,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)
+19 WRITE ?16,@$SELECT(LRPC="":"$J(X,LRCW)",1:LRPC)
+20 WRITE ?26,$PIECE(LR63DATA,"^",2)
+21 ; W ?26,$S($P(LR63DATA,"^",2)="N":"",1:$P(LR63DATA,"^",2))
+22 WRITE ?29,$PIECE(LR63DATA,"^",5)
+23 IF $GET(LRREFS)["$S("
DO MUMPRNGE(.LRREFS)
+24 ; W ?43,$E(LRREFS,1,15) K LRREFS
+25 ; W ?55,$S(LRTHER:"(TR)",1:"")
+26 ;
+27 ; I LRPLS'="" W ?59,$J("["_LRPLS_"]",6)
+28 ; W ?66,$$GETCOMPD^BLRUTIL4 ; IHS/MSC/MKK - LR*5.2*1031
+29 ; IHS/MSC/MKK - LR*5.2*1033
DO LRREFS^BLRLRRP1
+30 ;
+31 DO CONT
IF LRSTOP
QUIT
+32 ;
+33 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0
Begin DoDot:1
+34 SET LRINTP=0
+35 FOR
SET LRINTP=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
IF LRINTP<1
QUIT
WRITE !?7,"Eval: ",^(LRINTP)
DO CONT
IF LRSTOP
QUIT
End DoDot:1
IF LRSTOP
QUIT
+36 ;
+37 QUIT
+38 ;
+39 ;
MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
+1 NEW LOW,HIGH,RV1,RV2
+2 ;
+3 ; IHS/OIT/MKK - LR*5.2*1031 Note:
+4 ; If there is only one (1) Reference Range for a test, the LRLRRVF routine returns the Single Ref Range
+5 ; with "Ref: " prefixed to it. (See DATA+6 above.) However, that Ref Range could have a $SELECT statement,
+6 ; which means it gets passed to this subroutine. At this point, the RANGE variable must be a valid Mumps
+7 ; string, with no prefix. The 1031 changes below will try to ensure that.
+8 ;
+9 SET LOW=$$TRIM^XLFSTR($PIECE(RANGE,"-"),"LR"," ")
+10 ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
IF $EXTRACT(LOW,1,4)="Ref
SET LOW=$PIECE(LOW," ",2,999)
+11 ;
+12 SET HIGH=$$TRIM^XLFSTR($PIECE(RANGE,"-",2),"LR"," ")
+13 ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
IF $EXTRACT(HIGH,1,4)="Ref
SET HIGH=$PIECE(HIGH," ",2,999)
+14 ;
+15 IF $GET(LOW)=""&($GET(HIGH)="")
SET RANGE=" "
QUIT
+16 ;
+17 SET RV1=$$MUMPEVAL(LOW)
+18 SET RV2=$$MUMPEVAL(HIGH)
+19 ;
+20 SET RANGE=$$EN^LRLRRVF(RV1,RV2)
+21 ;
+22 ; I $G(RV1)=""&($G(RV2)="") S RANGE=" " Q
+23 ;
+24 ; S RANGE=RV1_" - "_RV2
+25 QUIT
+26 ;
MUMPEVAL(EVAL) ; EP
+1 NEW STR,WOT
+2 ;
+3 ; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
+4 ; reference range code has been mis-parsed. Return NULL.
+5 IF EVAL'["$S("
Begin DoDot:1
+6 IF EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&")
SET EVAL=""
End DoDot:1
QUIT EVAL
+7 ;
+8 ; If there is an "(" in the string, but no ")", that means the reference range code is too complex
+9 ; and/or has been mis-parsed. Return NULL.
+10 IF EVAL'[")"
QUIT ""
+11 ;
+12 SET STR="WOT="_EVAL
+13 SET @STR
+14 ;
+15 ; ANY punctuation in string means parsing failed. Return NULL.
+16 IF WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&")
SET WOT=""
+17 ;
+18 QUIT WOT
+19 ;
CHECK IF LRTC+11>(IOSL-$Y)
DO FOOT
IF LRSTOP
QUIT
DO HDR
+1 QUIT
+2 ;
CONT ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
+1 ; Q:($Y+5)<IOSL
+2 ; IHS/MSC/MKK - LR*5.2*1038
IF ($Y+9)<IOSL
QUIT
+3 ;
+4 DO BOTTOMPG
+5 DO FOOT
+6 IF LRSTOP
QUIT
+7 ;
+8 DO HDR
+9 WRITE !!,$$CJ^XLFSTR(">> CONTINUATION OF "_$PIECE(LR0,U,6)_" <<",IOM)
+10 DO COLHEADS
+11 QUIT
+12 ; End IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
+13 ;
+14 ;
+15 ; From LRRP, LRRP2, LRRP3
+1 ; If stop, then quit
IF LRSTOP
QUIT
+2 ; Double check to stop -- IHS/OIT/MKK - LR*5.2*1030
IF +$GET(LREND)!(+$GET(LRIDT)>+$GET(LREDT))
QUIT
+3 ;
+4 NEW LRIRAP,WOTERR
+5 ;
+6 SET LRIRAP=$$GET1^DIQ(9009029,+$GET(DUZ(2)),"INTERIM REPORT ADDRESS PAGE",,,"WOTERR")
+7 IF $GET(LRIRAP)="NO"!($GET(LRIRAP)="")
Begin DoDot:1
+8 NEW NUMSITES,WOTSITE
+9 SET (NUMSITES,WOTSITE)=0
+10 FOR
SET WOTSITE=$ORDER(LRPLS(WOTSITE))
IF WOTSITE=""
QUIT
Begin DoDot:2
+11 SET NUMSITES=NUMSITES+1
+12 IF +$LENGTH($$NAME^XUAF4(WOTSITE))+$LENGTH($$PADD^XUAF4(WOTSITE))>IOM
SET NUMSITES=NUMSITES+1
End DoDot:2
+13 WRITE !
+14 IF $Y'<(IOSL-(5+NUMSITES))
WRITE !
+15 ; Get to "bottom" of the page
FOR I=$Y:1:(IOSL-(5+NUMSITES))
WRITE !
+16 ; Print sites & addresses
DO SITELIST^LRRP2
End DoDot:1
+17 ;
+18 ; Check again due to TRUE issues with the ELSE statement.
+19 ; "Go to" bottom of the page
IF $GET(LRIRAP)="YES"
FOR I=$Y:1:(IOSL-4)
WRITE !
+20 ; LR*5.2*1038 - "Go to" bottom of the page
IF $GET(LRIRAP)="YES"
FOR I=$Y:1:(IOSL-5)
WRITE !
+21 ;
+22 IF $EXTRACT(IOST,1,2)'="C-"
Begin DoDot:1
+23 ; DO NOT FILE flag
NEW DONOTF
+24 SET DONOTF=$$GET1^DIQ(9009029,+$GET(DUZ(2))_",3","INTERIM REPORT DO NOT FILE")
+25 IF $GET(DONOTF)["Y"
WRITE !,"INTERIM REPORT DO NOT FILE",?30,$EXTRACT(PNM,1,23)," HRCN:",HRCN,?70,LRDT0,!
+26 IF $GET(DONOTF)'["Y"
WRITE PNM," HRCN:",HRCN,?70,LRDT0,!
End DoDot:1
QUIT
+27 ;
+28 ; W !,$E(PNM,1,23),?28,HRCN,?40,LRDT0
+29 ; IHS/MSC/MKK - LR*5.2*1038
WRITE !,PNM,?30," HRCN:",HRCN,?46,LRDT0
+30 READ ?60,"PRESS '^' TO STOP ",X:DTIME
IF X=""
SET X=1
IF (".^"[X)!('$TEST)
SET LRSTOP=1
+31 QUIT
+32 ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified FOOT Code
+33 ;
HDR ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
+1 IF ($GET(LRJ02))!($GET(LRJ0))!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET LRHF=0
SET LRJ02=1
+3 IF '$DATA(LRPG)
SET LRPG=0
+4 SET LRPG=LRPG+1
+5 ; I $E(IOST,1)="P" W !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!
+6 ; IHS/MSC/MKK - LR*5.2*1038
IF $EXTRACT(IOST)'="C"
WRITE !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",80),!
+7 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
DO ^LRAIPRIV
WRITE !
+8 ; W "Printed at: ",?65,"page ",LRPG ; IHS/OIT/MKK - LR*5.2*1028
+9 ; W "Printed at: ",?65,"page ",LRPG,! ; IHS/OIT/MKK - LR*5.2*1039
+10 ;
+11 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+12 Begin DoDot:1
+13 NEW PAGESTR,TAB
+14 SET PAGESTR="page "_LRPG
+15 SET TAB=(IOM-$LENGTH(PAGESTR))-2
+16 WRITE "Printed at: ",?TAB,PAGESTR,!
End DoDot:1
+17 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+18 ;
+19 DO LABHDR^BLRUTIL2
+20 WRITE !,PNM,?45,"Date/Time Printed: ",$$FMTE^XLFDT($$NOW^XLFDT,"2MZ")
+21 ;
+22 NEW AGE
+23 ; GIMC Correction
IF +$PIECE($GET(^LR(LRDFN,0)),"^",2)=2
SET DOB=$$DOB^AUPNPAT(+$PIECE($GET(^LR(LRDFN,0)),"^",3))
+24 IF DOB>0
Begin DoDot:1
+25 ; Age as of Today
SET AGE=$$UP^XLFSTR($$DATE^LRDAGE(DOB))
+26 ; If Age in Years, get rid of "YR" string.
IF AGE["YR"
SET AGE=+AGE
End DoDot:1
+27 ;
+28 WRITE !?5,"HRCN:",HRCN
+29 ; W ?25,"SEX:",SEX
+30 ; W ?35,"DOB:",$S(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
+31 ; W:+$G(AGE)>0 ?54,"CURRENT AGE:",AGE
+32 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+33 WRITE ?20,"SEX:",SEX
+34 WRITE ?27,"DOB:",$SELECT(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
+35 ; W:+$G(AGE)>0 ?45,"CURRENT AGE:",AGE
+36 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+37 NEW DOD
+38 ; S DOD=+$$GET1^DIQ(2,DFN,.351,"I") ; Date of Death
+39 ; IHS/MSC/MKK - LR*5.2*1041
SET DOD=+$$GET1^DIQ(+$GET(LRDPF),DFN,.351,"I")
+40 ; W:'DOD&(AGE) ?45,"CURRENT AGE:",AGE
+41 ; IHS/MSC/MKK - LR*5.2*1041
IF 'DOD&(AGE)&('$$GET^XPAR("ALL","BLR DOB ONLY",1,"Q"))
WRITE ?45,"CURRENT AGE:",AGE
+42 IF DOD
WRITE ?45,"DIED:",$$FMTE^XLFDT(DOD,"D")
+43 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+44 NEW LOCIEN,LOCDESC
+45 SET LOCIEN=+$PIECE($PIECE(LR0,"^",13),";")
+46 SET LOCDESC=$PIECE($GET(^SC(LOCIEN,0)),"^")
+47 ; W:$L(LOCDESC)<1!($L(LOCDESC)>14) ?62,"LOC:",LROC
+48 ; W:$L(LOCDESC)>0&($L(LOCDESC)<15) ?62,"LOC:",LOCDESC
+49 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+50 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+51 IF $LENGTH(LOCDESC)<1!($LENGTH(LOCDESC)>12)
WRITE ?64,"LOC:",$EXTRACT(LROC,1,12)
+52 IF $LENGTH(LOCDESC)>0&($LENGTH(LOCDESC)<12)
WRITE ?64,"LOC:",LOCDESC
+53 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+54 QUIT
+55 ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
+56 ;
ORU ; Display remote ordering info if available
+1 NEW LRX,IENS
+2 ; S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU")),IENS=LRIDT_","_LRDFN_","
+3 ; D EN^DDIOL("Accession [UID]: "_$P(LR0,"^",6)_" ["_$P(LRX,"^")_"]","","!")
+4 ;
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+6 NEW LRZERO
+7 SET LRZERO=$GET(^LR(LRDFN,LRSS,LRIDT,0))
SET LRX=$GET(^("ORU"))
SET IENS=LRIDT_","_LRDFN_","
+8 IF $LENGTH(LRX)
DO EN^DDIOL("Accession [UID]: "_$PIECE(LRZERO,U,6)_" ["_$PIECE(LRX,U)_"]")
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+10 ;
+11 IF $PIECE(LRX,"^",3)
Begin DoDot:1
+12 DO EN^DDIOL("Ordering Site: "_$$GET1^DIQ(63.04,IENS,.33,""),"","!?2")
+13 DO EN^DDIOL(" Ordering Site UID: "_$PIECE(LRX,"^",5),"","?43")
End DoDot:1
+14 IF $PIECE(LRX,"^",2)
DO EN^DDIOL("Collecting Site: "_$$GET1^DIQ(63.04,IENS,.32,""),"","!")
+15 QUIT
+16 ;
+17 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
LASTPAGE ; EP - Last Page
+1 NEW CNT,HNOW,I
+2 SET (CNT,I)=0
FOR
SET I=$ORDER(LRPLS(I))
IF I=""
QUIT
SET CNT=CNT+1
+3 SET CNT=CNT+1
+4 IF $EXTRACT(IOST,1,2)="C-"
FOR I=$Y:1:((IOSL-6)-CNT)
WRITE !
+5 IF '$TEST
WRITE !!
+6 DO SITELIST^LRRP2
+7 WRITE !!,PNM,?30," HRCN:",HRCN,?54,LRDT0
+8 QUIT
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1038
