LRRP1NWC.m

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

FOOT ;from LRRP, LRRP2, LRRP3

 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 

FOOT      ;from LRRP, LRRP2, LRRP3

 +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