LRRP1 ;SLC/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ;11/9/88 17:31 [ 04/28/2003 2:47 PM ]
;;5.2;LR;**1004,1013,1016,1018,1019**;MAR 25, 2004
;;5.2;LAB SERVICE;**153,221,283**;Sep 27, 1994
;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=9999999-LRCDT
. . F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:$E($G(^(LRCAN,0)))="*"
. D TEST Q:LRSTOP
Q
TEST S LRIDT=9999999-LRCDT,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" 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
Q:'$G(LRCAN)&('$P(LR0,U,3)) D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP
;----- BEGIN IHS MODIFICATION LR*5.2*1016
;The following lines added per appendix A of RPMS Lab E-sig enhancement V5.2 Technical Manual IHS/HQW/SCR - 8/23/01
;Set lab audit
;I $P(XQY0,U)="LRRS"!($P(XQY0,U)="BLR LRRD BY MD") D
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
;----- END IHS MODIFICATION
S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
W !!,?7,"Provider: ",LRDOC
;----- BEGIN IHS MODIFATIONS
;CHECK IF E-SIG TURNED ON AND ORDERING PROVIDER IS PARTICIPATING IN E-SIG
D:'$G(BLRGUI) ESIGINFO^BLRUTIL
;----- END IHS MODIFICATIONS
;W !,?7,"Specimen: ",$P(^LAB(61,LRSPEC,0),U)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1016 IHS TESTING CHANGE
W !,?7,"Specimen: ",$P(^LAB(61,LRSPEC,0),U)
;----- END IHS MODIFICATIONS
D ORU
S Y=LRCDT D DD^LRX W !!,?30,"Specimen Collection Date: ",Y
W !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
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")) W !,"Comment: " S LRCMNT=0 F I=0:0 S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1 W ^(LRCMNT) D
. D CONT Q:LRSTOP
. W:$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) !?9
Q:LRSTOP D EQUALS^LRX
W !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
S LRFOOT=1
Q
DATA S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
S X=$P(LRDATA,U,7),LRFFLG=$P(LRDATA,U,8),LRPLS=$P(LRDATA,U,9)
S:$G(LRPLS) LRPLS(LRPLS)=LRPLS Q:X=""
W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
W ?27,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",LRFFLG
S X=$S($D(^LAB(60,LRTSTS,1,LRSPEC,0)):^(0),1:"")
Q:'$L(X)
S LRTHER=$S($L($P(X,U,11,12))>1:1,1:0)
S LRLO=$S(LRTHER:$P(X,U,11),1:$P(X,U,2))
S LRHI=$S(LRTHER:$P(X,U,12),1:$P(X,U,3))
S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
W ?38," ",$P(X,U,7),?51,$J(LRLO,4),$S($L(LRHI):" - "_$J(LRHI,4),1:"")
W ?63,$S(LRTHER:"(Ther. range)",1:"")
I LRPLS'="" W ?68,"[",LRPLS,"]"
D CONT Q:LRSTOP
I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 S LRINTP=0 F I=0:0 S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1 W !?7,"Eval: ",^(LRINTP) D CONT Q:LRSTOP
Q
CHECK I LRTC+11>(IOSL-$Y) D FOOT Q:LRSTOP D HDR
Q
CONT I $Y+5>IOSL D FOOT Q:LRSTOP D HDR W !?20,">> CONTINUATION OF ",$P(LR0,U,6)," <<",!
Q
Q:LRSTOP F I=$Y:1:IOSL-4 W !
;----- BEGIN IHS MODIFICATION LR*5.2*1016
;I $E(IOST,1,2)'="C-" W !,PNM,?40," ",SSN," ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"),! Q
;----- BEGIN IHS MODIFICATION LR*5.2*1019 -- Do not print WORK COPY
; I $E(IOST,1,2)'="C-" W !,"WORK COPY - DO NOT FILE ",PNM,?40," ",HRCN," ",LRDT0,! Q ;IHS/ANMC/CLS 08/18/96
I $E(IOST,1,2)'="C-" W !," ",PNM,?40," ",HRCN," ",LRDT0,! Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATION LR*5.2*1019 -- Do not print WORK COPY
; I $E(IOST,1,2)'="C-" W !," ",PNM,?40," ",HRCN," ",LRDT0,! Q ;IHS/ANMC/CLS 08/18/96
;W !,PNM,?25," ",SSN," ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"),?59," PRESS '^' TO STOP "
W !,PNM,?25," ",HRCN," ",LRDT0,?59," PRESS '^' TO STOP " ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATION
R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LRSTOP=1
Q
HDR ;Add Printed at, page #, change age to dob 7/2002 cka
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
;W !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
;S X=$$PADD^XUAF4(DUZ(2))
;W " ",$P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1017
I $T(NAME^XUAF4)]"",($T(PADD^XUAF4)]"") D
.W !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
.S X=$$PADD^XUAF4(DUZ(2))
.W " ",$P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
;----- END IHS MODIFICATIONS
W !
W !,PNM,?45,"Report date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")
;W !?5,"SSN: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
;----- BEGIN IHS MODIFICATION LR*5.2*1016
W !?5,"HRCN: ",HRCN," SEX: ",SEX," AGE: ",AGE," LOC: ",LROC ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATION
Q
;
ORU ; Display remote ordering info if available
N LRX
S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU"))
D EN^DDIOL("Accession [UID]: "_$P(LR0,"^",6)_" ["_$P(LRX,"^")_"]","","!")
I $P(LRX,"^",2) D
. D EN^DDIOL("Ordering Site: "_$$EXTERNAL^DILFD(63.04,.32,"",$P(LRX,"^",2)),"","!?2")
. D EN^DDIOL(" Ordering Site UID: "_$P(LRX,"^",5),"","?43")
I $P(LRX,"^",3) D EN^DDIOL("Collecting Site: "_$$EXTERNAL^DILFD(63.04,.33,"",$P(LRX,"^",3)),"","!")
Q
LRRP1 ;SLC/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ;11/9/88 17:31 [ 04/28/2003 2:47 PM ]
+1 ;;5.2;LR;**1004,1013,1016,1018,1019**;MAR 25, 2004
+2 ;;5.2;LAB SERVICE;**153,221,283**;Sep 27, 1994
+3 ;from LRRP, LRRP2, LRRP3
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
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=9999999-LRCDT
+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
TEST SET LRIDT=9999999-LRCDT
SET LRSS=$PIECE(^TMP("LR",$JOB,"TP",LRAAO),U,2)
+1 SET LR0=$SELECT($DATA(^(LRAAO,LRCDT))#2:^(LRCDT),1:"")
SET LRTC=$PIECE(LR0,U,12)
+2 IF LRSS="MI"
SET LRH=1
IF LRFOOT
DO FOOT
IF LRSTOP
QUIT
DO EN1^LRMIPC
SET LRHF=1
SET LRFOOT=0
KILL A,Z,LRH
IF LREND
SET LREND=0
SET LRSTOP=1
QUIT
+3 IF '$GET(LRCAN)&('$PIECE(LR0,U,3))
QUIT
DO @$SELECT(LRHF:"HDR",1:"CHECK")
IF LRSTOP
QUIT
+4 ;----- BEGIN IHS MODIFICATION LR*5.2*1016
+5 ;The following lines added per appendix A of RPMS Lab E-sig enhancement V5.2 Technical Manual IHS/HQW/SCR - 8/23/01
+6 ;Set lab audit
+7 ;I $P(XQY0,U)="LRRS"!($P(XQY0,U)="BLR LRRD BY MD") D
+8 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
+9 IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
DO ^BLRALAU
End DoDot:1
+10 ;----- END IHS MODIFICATION
+11 SET LRSPEC=+$PIECE(LR0,U,5)
SET X=$PIECE(LR0,U,10)
DO DOC^LRX
+12 WRITE !!,?7,"Provider: ",LRDOC
+13 ;----- BEGIN IHS MODIFATIONS
+14 ;CHECK IF E-SIG TURNED ON AND ORDERING PROVIDER IS PARTICIPATING IN E-SIG
+15 IF '$GET(BLRGUI)
DO ESIGINFO^BLRUTIL
+16 ;----- END IHS MODIFICATIONS
+17 ;W !,?7,"Specimen: ",$P(^LAB(61,LRSPEC,0),U)
+18 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1016 IHS TESTING CHANGE
+19 WRITE !,?7,"Specimen: ",$PIECE(^LAB(61,LRSPEC,0),U)
+20 ;----- END IHS MODIFICATIONS
+21 DO ORU
+22 SET Y=LRCDT
DO DD^LRX
WRITE !!,?30,"Specimen Collection Date: ",Y
+23 WRITE !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
+24 SET LRPO=0
FOR
SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
IF LRPO'>0
QUIT
SET LRDATA=^(LRPO)
DO DATA
IF LRSTOP
QUIT
+25 IF LRSTOP
QUIT
+26 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))
WRITE !,"Comment: "
SET LRCMNT=0
FOR I=0:0
SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
IF LRCMNT<1
QUIT
WRITE ^(LRCMNT)
Begin DoDot:1
+27 DO CONT
IF LRSTOP
QUIT
+28 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
WRITE !?9
End DoDot:1
+29 IF LRSTOP
QUIT
DO EQUALS^LRX
+30 WRITE !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
+31 SET LRFOOT=1
+32 QUIT
DATA SET LRTSTS=+LRDATA
SET LRPC=$PIECE(LRDATA,U,5)
SET LRSUB=$PIECE(LRDATA,U,6)
+1 SET X=$PIECE(LRDATA,U,7)
SET LRFFLG=$PIECE(LRDATA,U,8)
SET LRPLS=$PIECE(LRDATA,U,9)
+2 IF $GET(LRPLS)
SET LRPLS(LRPLS)=LRPLS
IF X=""
QUIT
+3 WRITE !?5,$SELECT($LENGTH($PIECE(LRDATA,U,2))>20:$PIECE(LRDATA,U,3),1:$PIECE(LRDATA,U,2))
+4 WRITE ?27,@$SELECT(LRPC="":"$J(X,LRCW)",1:LRPC)," ",LRFFLG
+5 SET X=$SELECT($DATA(^LAB(60,LRTSTS,1,LRSPEC,0)):^(0),1:"")
+6 IF '$LENGTH(X)
QUIT
+7 SET LRTHER=$SELECT($LENGTH($PIECE(X,U,11,12))>1:1,1:0)
+8 SET LRLO=$SELECT(LRTHER:$PIECE(X,U,11),1:$PIECE(X,U,2))
+9 SET LRHI=$SELECT(LRTHER:$PIECE(X,U,12),1:$PIECE(X,U,3))
+10 SET @("LRLO="_$SELECT($LENGTH(LRLO):LRLO,1:""""""))
+11 SET @("LRHI="_$SELECT($LENGTH(LRHI):LRHI,1:""""""))
+12 WRITE ?38," ",$PIECE(X,U,7),?51,$JUSTIFY(LRLO,4),$SELECT($LENGTH(LRHI):" - "_$JUSTIFY(LRHI,4),1:"")
+13 WRITE ?63,$SELECT(LRTHER:"(Ther. range)",1:"")
+14 IF LRPLS'=""
WRITE ?68,"[",LRPLS,"]"
+15 DO CONT
IF LRSTOP
QUIT
+16 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0
SET LRINTP=0
FOR I=0:0
SET LRINTP=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
IF LRINTP<1
QUIT
WRITE !?7,"Eval: ",^(LRINTP)
DO CONT
IF LRSTOP
QUIT
+17 QUIT
CHECK IF LRTC+11>(IOSL-$Y)
DO FOOT
IF LRSTOP
QUIT
DO HDR
+1 QUIT
CONT IF $Y+5>IOSL
DO FOOT
IF LRSTOP
QUIT
DO HDR
WRITE !?20,">> CONTINUATION OF ",$PIECE(LR0,U,6)," <<",!
+1 QUIT
+1 IF LRSTOP
QUIT
FOR I=$Y:1:IOSL-4
WRITE !
+2 ;----- BEGIN IHS MODIFICATION LR*5.2*1016
+3 ;I $E(IOST,1,2)'="C-" W !,PNM,?40," ",SSN," ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"),! Q
+4 ;----- BEGIN IHS MODIFICATION LR*5.2*1019 -- Do not print WORK COPY
+5 ; I $E(IOST,1,2)'="C-" W !,"WORK COPY - DO NOT FILE ",PNM,?40," ",HRCN," ",LRDT0,! Q ;IHS/ANMC/CLS 08/18/96
+6 ;IHS/ANMC/CLS 08/18/96
IF $EXTRACT(IOST,1,2)'="C-"
WRITE !," ",PNM,?40," ",HRCN," ",LRDT0,!
QUIT
+7 ;----- END IHS MODIFICATION LR*5.2*1019 -- Do not print WORK COPY
+8 ; I $E(IOST,1,2)'="C-" W !," ",PNM,?40," ",HRCN," ",LRDT0,! Q ;IHS/ANMC/CLS 08/18/96
+9 ;W !,PNM,?25," ",SSN," ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ"),?59," PRESS '^' TO STOP "
+10 ;IHS/ANMC/CLS 08/18/96
WRITE !,PNM,?25," ",HRCN," ",LRDT0,?59," PRESS '^' TO STOP "
+11 ;----- END IHS MODIFICATION
+12 READ X:DTIME
IF X=""
SET X=1
IF (".^"[X)!('$TEST)
SET LRSTOP=1
+13 QUIT
HDR ;Add Printed at, page #, change age to dob 7/2002 cka
+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 IF $EXTRACT(IOST,1)="P"
Begin DoDot:1
+6 WRITE !!!!
+7 SET X="CLINICAL LABORATORY REPORT"
+8 WRITE ?(80-$LENGTH(X)\2),X,!
End DoDot:1
+9 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
DO ^LRAIPRIV
WRITE !
+10 WRITE "Printed at: ",?65,"page ",LRPG
+11 ;W !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
+12 ;S X=$$PADD^XUAF4(DUZ(2))
+13 ;W " ",$P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
+14 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1017
+15 IF $TEXT(NAME^XUAF4)]""
IF ($TEXT(PADD^XUAF4)]"")
Begin DoDot:1
+16 WRITE !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
+17 SET X=$$PADD^XUAF4(DUZ(2))
+18 WRITE " ",$PIECE(X,U)," ",$PIECE(X,U,2),", ",$PIECE(X,U,3)," ",$PIECE(X,U,4)
End DoDot:1
+19 ;----- END IHS MODIFICATIONS
+20 WRITE !
+21 WRITE !,PNM,?45,"Report date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5FMPZ")
+22 ;W !?5,"SSN: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
+23 ;----- BEGIN IHS MODIFICATION LR*5.2*1016
+24 ;IHS/ANMC/CLS 08/18/96
WRITE !?5,"HRCN: ",HRCN," SEX: ",SEX," AGE: ",AGE," LOC: ",LROC
+25 ;----- END IHS MODIFICATION
+26 QUIT
+27 ;
ORU ; Display remote ordering info if available
+1 NEW LRX
+2 SET LRX=$GET(^LR(LRDFN,"CH",LRIDT,"ORU"))
+3 DO EN^DDIOL("Accession [UID]: "_$PIECE(LR0,"^",6)_" ["_$PIECE(LRX,"^")_"]","","!")
+4 IF $PIECE(LRX,"^",2)
Begin DoDot:1
+5 DO EN^DDIOL("Ordering Site: "_$$EXTERNAL^DILFD(63.04,.32,"",$PIECE(LRX,"^",2)),"","!?2")
+6 DO EN^DDIOL(" Ordering Site UID: "_$PIECE(LRX,"^",5),"","?43")
End DoDot:1
+7 IF $PIECE(LRX,"^",3)
DO EN^DDIOL("Collecting Site: "_$$EXTERNAL^DILFD(63.04,.33,"",$PIECE(LRX,"^",3)),"","!")
+8 QUIT
