LRRP1.m

LRRP1 ;DALOI/STAFF - PRINT THE DATA FOR INTERIM REPORTS ;11/18/11  16:33

 ;;5.2;LAB SERVICE;**153,221,283,286,356,372,350**;Sep 27, 1994;Build 230

 ;

 ; from LRRP, LRRP2, LRRP3, LRMIPSU

 ;

PRINT ;

 S:$G(SEX)="" SEX="M" S:$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 ;

 N LRRELDT,LRX

 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

 ;

 ; Protect against results for AP subscripts being processed from file #69 orders.

 I LRSS'="CH" Q

 ;

 Q:'$G(LRCAN)&('$P(LR0,U,3))  D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP

 S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX

 ;

 ; Display reporting lab

 I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D

 . S LRX=+$G(^LR(LRDFN,LRSS,LRIDT,"RF"))

 . I LRX D RL(LRX)

 ;

 I LRDOC?1"REF:"1.AN D

 . S LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)

 . I LRX'="" S LRDOC=LRX

 W !!,?7,"Provider: ",LRDOC

 W !,?7,"Specimen: ",$P($G(^LAB(61,LRSPEC,0),"<no specimen on file>"),U)

 D ORU

 S LRRELDT=$P(^TMP("LR",$J,"TP",LRAAO,LRCDT),U,3)

 W !,"Report Released: ",$$FMTE^XLFDT(LRRELDT,"M")

 W !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")

 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")) 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 EQUALS^LRX

 W !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"

 S LRFOOT=1

 Q

 ;

 ;

DATA ;

 N LR63DATA,LRREFS,LRX

 ;

 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)

 I LRPLS S LRPLS(LRPLS)=LRPLS

 ;

 ; Find reference lab filler order number

 S LREPR=LRDFN_","_LRSS_","_LRIDT_","_$P(LRDATA,"^",10)

 S LRX=$O(^LR(LRDFN,"EPR","AD",LREPR,4,""))

 I LRX S LREPR(4,LREPR,LRX)=""

 ;

 ;W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))

 ; Insure something is printed as test name - either print name or #.01 field

 I $L($P(LRDATA,U,2))>25,$P(LRDATA,U,3)'="" W !,$P(LRDATA,U,3)

 E  W !,$E($P(LRDATA,U,2),1,25)

 S X=$P(LR63DATA,"^")

 W ?27,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)

 I $X>39 W !

 W ?40,$P(LR63DATA,U,5)

 I $X>50 W !

 W ?51,LRREFS

 ;

 I LRPLS'="" D

 . I $X>67 W !

 . W ?68,"[",LRPLS,"]"

 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

 ;

 ;

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

 ;

 N I

 Q:LRSTOP

 F I=$Y:1:IOSL-4 W !

 ;

 I $E(IOST,1,2)'="C-" D  Q

 . W !,PNM,?40,"  ",SSN,"  ",$$HTE^XLFDT($H,"1M"),!

 ;

 W !,PNM,?25,"  ",SSN,"  ",$$HTE^XLFDT($H,"1M"),?59," PRESS '^' TO STOP "

 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,LRPG=$G(LRPG)+1

 I $E(IOST,1)="P" W !!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!

 ;

 I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D PFAC(DUZ(2),LRPG)

 ;

 W !!,PNM,?44,"Report date: ",$$HTE^XLFDT($H,"M")

 W !?1,"Pat ID: ",SSN,"    SEX: ",SEX,"    DOB: ",$$FMTE^XLFDT(DOB),"    LOC: ",LROC

 Q

 ;

 ;

ORU ; Display remote ordering info if available

 ; Handle calls that don't pass parameters.

 D ORUA("",LRDFN,LRSS,LRIDT,0)

 Q

 ;

 ;

ORUA(LRARRAY,LRDFN,LRSS,LRIDT,LRFLAG) ; Display remote ordering info if available

 ; Call with LRARRAY = array with name/address info

 ;             LRDFN = file #63 ien

 ;              LRSS = file #63 subscript

 ;             LRIDT = file #63 internal data/time of specimen

 ;            LRFLAG = 0 (print facility info)

 ;                     1 (return facility info in LRARRAY)

 ;

 N A,IENS,LRFILE,LRX,LRY

 ;

 S LRFLAG=$G(LRFLAG,0)

 S LRFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)

 S LRX(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))

 S LRX("ORU")=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")),IENS=LRIDT_","_LRDFN_","

 ;

 S LRY="Accession [UID]: "_$P(LRX(0),"^",6)_" ["_$P(LRX("ORU"),"^")_"]"

 I LRSS="MI",$P(LRX(0),"^",10) S LRY=$$LJ^XLFSTR(LRY,43," ")_" Received: "_$$FMTE^XLFDT($P(LRX(0),"^",10),"M")

 I LRFLAG S A(1)=LRY

 E  D EN^DDIOL(LRY,"","!")

 ;

 I $P(LRX("ORU"),"^",3) D

 . S LRY=$$LJ^XLFSTR("Ordering Site: "_$$GET1^DIQ(LRFILE,IENS,.33,""),43," ")_" Ordering Site UID: "_$P(LRX("ORU"),"^",5)

 . I LRFLAG S A(2)=LRY

 . E  D EN^DDIOL(LRY,"","!?2")

 ;

 I $P(LRX("ORU"),"^",2) D

 . S LRY="Collecting Site: "_$$GET1^DIQ(LRFILE,IENS,.32,"")

 . I LRFLAG=1 S A(3)=LRY

 . E  D EN^DDIOL(LRY,"","!")

 ;

 I LRFLAG M LRARRAY=A

 ;

 Q

 ;

 ;

PFAC(LR4,LRPG,LRFLAG,LRARRAY) ; Display name/address of printing facility

 ; Call with LR4 = File #4 IEN

 ;          LRPG = current page number to print

 ;        LRFLAG = 0 (print facility info)

 ;                 1 (return facility info in LRARRAY)

 ;       LRARRAY = array with name/address info

 ;

 N A,CLIA,LRX,X

 S LRX=$$NAME^XUAF4(LR4),CLIA=$$ID^XUAF4("CLIA",LR4),LRFLAG=$G(LRFLAG,0)

 S A(1)="Printed at:"

 I $G(LRPG) S A(1)=$$LJ^XLFSTR(A(1),$G(IOM,80)-15)_"page "_LRPG

 S A(2)=LRX

 I CLIA'="" D

 . S X="[CLIA# "_CLIA_"]"

 . I $L(A(2))+$L(X)+1>$G(IOM,80) S A(2.5)=X

 . E  S A(2)=A(2)_" "_X

 S LRX=$$PADD^XUAF4(LR4),LRX(1)=$$WHAT^XUAF4(LR4,1.02)

 S A(3)=$P(LRX,U)_" "_$S(LRX(1)'="":LRX(1)_" ",1:"")_$P(LRX,U,2)_$S($P(LRX,U,3)'="":", ",1:"")_$P(LRX,U,3)_" "_$P(LRX,U,4)

 I 'LRFLAG D

 . S A(4)=" "

 . S A(1,"F")="?2",A(2,"F")="!?2",A(3,"F")="!?2",A(4,"F")="!"

 . I $D(A(2.5)) S A(2.5,"F")="!?2"

 . D EN^DDIOL(.A)

 I LRFLAG M LRARRAY=A

 ;

 Q

 ;

 ;

RL(LR4,LRFLAG,OUT) ; Display name/address of reporting laboratory

 ; Call with LR4: File #4 IEN

 ;        LRFLAG: <opt> 1=save to OUT array

 ;           OUT: <byref><opt>

 ;

 N A,CLIA,LRX,X,I

 S LRFLAG=$G(LRFLAG)

 K OUT

 S LRX=$$NAME^XUAF4(LR4),CLIA=$$ID^XUAF4("CLIA",LR4)

 S A(1)="Reporting Lab:" ;_LRX

 S A(2)=LRX

 I 'LRFLAG S A(1,"F")="!!?2",A(2,"F")="!?2"

 I CLIA'="" D

 . S X="[CLIA# "_CLIA_"]"

 . I $L(A(2))+$L(X)+1>$G(IOM,80) S A(2.5)=X S:'LRFLAG A(2.5,"F")="!?17"

 . E  S A(2)=A(2)_" "_X

 S LRX=$$PADD^XUAF4(LR4),LRX(1)=$$WHAT^XUAF4(LR4,1.02)

 S A(3)=$P(LRX,U)_" "_$P(LRX,U,2)_", "_$P(LRX,U,3)_" "_$P(LRX,U,4)

 S A(3)=$P(LRX,U)_" "_$S(LRX(1)'="":LRX(1)_" ",1:"")_$P(LRX,U,2)_$S($P(LRX,U,3)'="":", ",1:"")_$P(LRX,U,3)_" "_$P(LRX,U,4)

 I 'LRFLAG D

 . S A(4)=" ",A(3,"F")="!?2",A(4,"F")="!"

 . I $D(A(2.5)) S A(2.5,"F")="!?2"

 . D EN^DDIOL(.A)

 I LRFLAG M OUT=A

 ;

 Q

 ;

 ;

REFDOC(LRDFN,LRSS,LRIDT) ; Lookup LEDI referral free text provider name in file #63 on "ORUT" subscript

 ; Call with LRDFN = ien on entry in file #63

 ;            LRSS = file #63 subscript

 ;           LRIDT = inverse specimen date/time

 ;

 ; Returns     LRY = free text provider found on first test in file #63

 ;

 N LRI,LRX,LRY

 S LRI=0,(LRX,LRY)=""

 F  S LRI=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT",LRI)) Q:'LRI  S LRX=$P(^(LRI,0),"^",7) Q:LRX'=""

 I LRX'="" S LRY=LRX

 Q LRY

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRRP1   8321     printed  Feb 18, 2025@23:45:43                                                                                                                                                                                                       Page 2

LRRP1     ;DALOI/STAFF - PRINT THE DATA FOR INTERIM REPORTS ;11/18/11  16:33

 +1       ;;5.2;LAB SERVICE;**153,221,283,286,356,372,350**;Sep 27, 1994;Build 230

 +2       ;

 +3       ; from LRRP, LRRP2, LRRP3, LRMIPSU

 +4       ;

PRINT     ;

 +1        if $GET(SEX)=""

               SET SEX="M"

           if $GET(DOB)=""

               SET DOB="UNKNOWN"

 +2        SET LRAAO=0

           FOR 

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

               if LRAAO<1

                   QUIT 

               DO ORDER

               if LRSTOP

                   QUIT 

 +3        KILL ^TMP("LR",$JOB,"TP")

 +4        QUIT 

 +5       ;

 +6       ;

ORDER     ;

 +1        NEW LRCAN

 +2        SET LRCDT=0

 +3        FOR 

               SET LRCDT=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT))

               if LRCDT<1

                   QUIT 

               Begin DoDot:1

 +4                SET LRCAN=0

 +5                IF LRSS="CH"

                       Begin DoDot:2

 +6                        SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)

 +7                        FOR 

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

                               if LRCAN<1

                                   QUIT 

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

                                   QUIT 

                       End DoDot:2

 +8                DO TEST

                   if LRSTOP

                       QUIT 

               End DoDot:1

 +9        QUIT 

 +10      ;

 +11      ;

TEST      ;

 +1        NEW LRRELDT,LRX

 +2        SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)

 +3        SET LRSS=$PIECE(^TMP("LR",$JOB,"TP",LRAAO),U,2)

 +4        SET LR0=$SELECT($DATA(^(LRAAO,LRCDT))#2:^(LRCDT),1:"")

           SET LRTC=$PIECE(LR0,U,12)

 +5        IF LRSS="MI"

               Begin DoDot:1

 +6                SET LRH=1

                   if LRFOOT

                       DO FOOT

                   if LRSTOP

                       QUIT 

 +7                DO EN1^LRMIPC

 +8                SET LRHF=1

                   SET LRFOOT=0

 +9                KILL A,Z,LRH

 +10               if LREND

                       SET LREND=0

                       SET LRSTOP=1

               End DoDot:1

               QUIT 

 +11      ;

 +12      ; Protect against results for AP subscripts being processed from file #69 orders.

 +13       IF LRSS'="CH"

               QUIT 

 +14      ;

 +15       if '$GET(LRCAN)&('$PIECE(LR0,U,3))

               QUIT 

           DO @$SELECT(LRHF:"HDR",1:"CHECK")

           if LRSTOP

               QUIT 

 +16       SET LRSPEC=+$PIECE(LR0,U,5)

           SET X=$PIECE(LR0,U,10)

           DO DOC^LRX

 +17      ;

 +18      ; Display reporting lab

 +19       IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2

               Begin DoDot:1

 +20               SET LRX=+$GET(^LR(LRDFN,LRSS,LRIDT,"RF"))

 +21               IF LRX

                       DO RL(LRX)

               End DoDot:1

 +22      ;

 +23       IF LRDOC?1"REF:"1.AN

               Begin DoDot:1

 +24               SET LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)

 +25               IF LRX'=""

                       SET LRDOC=LRX

               End DoDot:1

 +26       WRITE !!,?7,"Provider: ",LRDOC

 +27       WRITE !,?7,"Specimen: ",$PIECE($GET(^LAB(61,LRSPEC,0),"<no specimen on file>"),U)

 +28       DO ORU

 +29       SET LRRELDT=$PIECE(^TMP("LR",$JOB,"TP",LRAAO,LRCDT),U,3)

 +30       WRITE !,"Report Released: ",$$FMTE^XLFDT(LRRELDT,"M")

 +31       WRITE !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")

 +32       WRITE !?5,"Test name",?30,"Result    units",?51,"Ref.   range",?66,"Site Code"

 +33       SET LRPO=0

 +34       FOR 

               SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))

               if LRPO'>0

                   QUIT 

               SET LRDATA=^(LRPO)

               DO DATA

               if LRSTOP

                   QUIT 

 +35       if LRSTOP

               QUIT 

 +36      ;

 +37       IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))

               Begin DoDot:1

 +38               WRITE !,"Comment: "

                   SET LRCMNT=0

 +39               FOR 

                       SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))

                       if LRCMNT<1

                           QUIT 

                       Begin DoDot:2

 +40                       WRITE ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)

 +41                       DO CONT

                           if LRSTOP

                               QUIT 

 +42                       if $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))

                               WRITE !?9

                       End DoDot:2

                       if LRSTOP

                           QUIT 

               End DoDot:1

 +43       if LRSTOP

               QUIT 

           DO EQUALS^LRX

 +44       WRITE !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"

 +45       SET LRFOOT=1

 +46       QUIT 

 +47      ;

 +48      ;

DATA      ;

 +1        NEW LR63DATA,LRREFS,LRX

 +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        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)

 +7        IF LRPLS

               SET LRPLS(LRPLS)=LRPLS

 +8       ;

 +9       ; Find reference lab filler order number

 +10       SET LREPR=LRDFN_","_LRSS_","_LRIDT_","_$PIECE(LRDATA,"^",10)

 +11       SET LRX=$ORDER(^LR(LRDFN,"EPR","AD",LREPR,4,""))

 +12       IF LRX

               SET LREPR(4,LREPR,LRX)=""

 +13      ;

 +14      ;W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))

 +15      ; Insure something is printed as test name - either print name or #.01 field

 +16       IF $LENGTH($PIECE(LRDATA,U,2))>25

               IF $PIECE(LRDATA,U,3)'=""

                   WRITE !,$PIECE(LRDATA,U,3)

 +17      IF '$TEST

               WRITE !,$EXTRACT($PIECE(LRDATA,U,2),1,25)

 +18       SET X=$PIECE(LR63DATA,"^")

 +19       WRITE ?27,@$SELECT(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$PIECE(LR63DATA,"^",2)

 +20       IF $X>39

               WRITE !

 +21       WRITE ?40,$PIECE(LR63DATA,U,5)

 +22       IF $X>50

               WRITE !

 +23       WRITE ?51,LRREFS

 +24      ;

 +25       IF LRPLS'=""

               Begin DoDot:1

 +26               IF $X>67

                       WRITE !

 +27               WRITE ?68,"[",LRPLS,"]"

               End DoDot:1

 +28       DO CONT

           if LRSTOP

               QUIT 

 +29      ;

 +30       IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0

               Begin DoDot:1

 +31               SET LRINTP=0

 +32               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 

 +33      ;

 +34       QUIT 

 +35      ;

 +36      ;

CHECK      IF LRTC+11>(IOSL-$Y)

               DO FOOT

               if LRSTOP

                   QUIT 

               DO HDR

 +1        QUIT 

 +2       ;

 +3       ;

CONT       IF $Y+5>IOSL

               DO FOOT

               if LRSTOP

                   QUIT 

               DO HDR

               WRITE !?20,">> CONTINUATION OF ",$PIECE(LR0,U,6)," <<",!

 +1        QUIT 

 +2       ;

 +3       ;

FOOT      ; from LRRP, LRRP2, LRRP3

 +1       ;

 +2        NEW I

 +3        if LRSTOP

               QUIT 

 +4        FOR I=$Y:1:IOSL-4

               WRITE !

 +5       ;

 +6        IF $EXTRACT(IOST,1,2)'="C-"

               Begin DoDot:1

 +7                WRITE !,PNM,?40,"  ",SSN,"  ",$$HTE^XLFDT($HOROLOG,"1M"),!

               End DoDot:1

               QUIT 

 +8       ;

 +9        WRITE !,PNM,?25,"  ",SSN,"  ",$$HTE^XLFDT($HOROLOG,"1M"),?59," PRESS '^' TO STOP "

 +10       READ X:DTIME

           if X=""

               SET X=1

           if (".^"[X)!('$TEST)

               SET LRSTOP=1

 +11       QUIT 

 +12      ;

 +13      ;

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

           SET LRPG=$GET(LRPG)+1

 +3        IF $EXTRACT(IOST,1)="P"

               WRITE !!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!

 +4       ;

 +5        IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1

               DO PFAC(DUZ(2),LRPG)

 +6       ;

 +7        WRITE !!,PNM,?44,"Report date: ",$$HTE^XLFDT($HOROLOG,"M")

 +8        WRITE !?1,"Pat ID: ",SSN,"    SEX: ",SEX,"    DOB: ",$$FMTE^XLFDT(DOB),"    LOC: ",LROC

 +9        QUIT 

 +10      ;

 +11      ;

ORU       ; Display remote ordering info if available

 +1       ; Handle calls that don't pass parameters.

 +2        DO ORUA("",LRDFN,LRSS,LRIDT,0)

 +3        QUIT 

 +4       ;

 +5       ;

ORUA(LRARRAY,LRDFN,LRSS,LRIDT,LRFLAG) ; Display remote ordering info if available

 +1       ; Call with LRARRAY = array with name/address info

 +2       ;             LRDFN = file #63 ien

 +3       ;              LRSS = file #63 subscript

 +4       ;             LRIDT = file #63 internal data/time of specimen

 +5       ;            LRFLAG = 0 (print facility info)

 +6       ;                     1 (return facility info in LRARRAY)

 +7       ;

 +8        NEW A,IENS,LRFILE,LRX,LRY

 +9       ;

 +10       SET LRFLAG=$GET(LRFLAG,0)

 +11       SET LRFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)

 +12       SET LRX(0)=$GET(^LR(LRDFN,LRSS,LRIDT,0))

 +13       SET LRX("ORU")=$GET(^LR(LRDFN,LRSS,LRIDT,"ORU"))

           SET IENS=LRIDT_","_LRDFN_","

 +14      ;

 +15       SET LRY="Accession [UID]: "_$PIECE(LRX(0),"^",6)_" ["_$PIECE(LRX("ORU"),"^")_"]"

 +16       IF LRSS="MI"

               IF $PIECE(LRX(0),"^",10)

                   SET LRY=$$LJ^XLFSTR(LRY,43," ")_" Received: "_$$FMTE^XLFDT($PIECE(LRX(0),"^",10),"M")

 +17       IF LRFLAG

               SET A(1)=LRY

 +18      IF '$TEST

               DO EN^DDIOL(LRY,"","!")

 +19      ;

 +20       IF $PIECE(LRX("ORU"),"^",3)

               Begin DoDot:1

 +21               SET LRY=$$LJ^XLFSTR("Ordering Site: "_$$GET1^DIQ(LRFILE,IENS,.33,""),43," ")_" Ordering Site UID: "_$PIECE(LRX("ORU"),"^",5)

 +22               IF LRFLAG

                       SET A(2)=LRY

 +23              IF '$TEST

                       DO EN^DDIOL(LRY,"","!?2")

               End DoDot:1

 +24      ;

 +25       IF $PIECE(LRX("ORU"),"^",2)

               Begin DoDot:1

 +26               SET LRY="Collecting Site: "_$$GET1^DIQ(LRFILE,IENS,.32,"")

 +27               IF LRFLAG=1

                       SET A(3)=LRY

 +28              IF '$TEST

                       DO EN^DDIOL(LRY,"","!")

               End DoDot:1

 +29      ;

 +30       IF LRFLAG

               MERGE LRARRAY=A

 +31      ;

 +32       QUIT 

 +33      ;

 +34      ;

PFAC(LR4,LRPG,LRFLAG,LRARRAY) ; Display name/address of printing facility

 +1       ; Call with LR4 = File #4 IEN

 +2       ;          LRPG = current page number to print

 +3       ;        LRFLAG = 0 (print facility info)

 +4       ;                 1 (return facility info in LRARRAY)

 +5       ;       LRARRAY = array with name/address info

 +6       ;

 +7        NEW A,CLIA,LRX,X

 +8        SET LRX=$$NAME^XUAF4(LR4)

           SET CLIA=$$ID^XUAF4("CLIA",LR4)

           SET LRFLAG=$GET(LRFLAG,0)

 +9        SET A(1)="Printed at:"

 +10       IF $GET(LRPG)

               SET A(1)=$$LJ^XLFSTR(A(1),$GET(IOM,80)-15)_"page "_LRPG

 +11       SET A(2)=LRX

 +12       IF CLIA'=""

               Begin DoDot:1

 +13               SET X="[CLIA# "_CLIA_"]"

 +14               IF $LENGTH(A(2))+$LENGTH(X)+1>$GET(IOM,80)

                       SET A(2.5)=X

 +15              IF '$TEST

                       SET A(2)=A(2)_" "_X

               End DoDot:1

 +16       SET LRX=$$PADD^XUAF4(LR4)

           SET LRX(1)=$$WHAT^XUAF4(LR4,1.02)

 +17       SET A(3)=$PIECE(LRX,U)_" "_$SELECT(LRX(1)'="":LRX(1)_" ",1:"")_$PIECE(LRX,U,2)_$SELECT($PIECE(LRX,U,3)'="":", ",1:"")_$PIECE(LRX,U,3)_" "_$PIECE(LRX,U,4)

 +18       IF 'LRFLAG

               Begin DoDot:1

 +19               SET A(4)=" "

 +20               SET A(1,"F")="?2"

                   SET A(2,"F")="!?2"

                   SET A(3,"F")="!?2"

                   SET A(4,"F")="!"

 +21               IF $DATA(A(2.5))

                       SET A(2.5,"F")="!?2"

 +22               DO EN^DDIOL(.A)

               End DoDot:1

 +23       IF LRFLAG

               MERGE LRARRAY=A

 +24      ;

 +25       QUIT 

 +26      ;

 +27      ;

RL(LR4,LRFLAG,OUT) ; Display name/address of reporting laboratory

 +1       ; Call with LR4: File #4 IEN

 +2       ;        LRFLAG: <opt> 1=save to OUT array

 +3       ;           OUT: <byref><opt>

 +4       ;

 +5        NEW A,CLIA,LRX,X,I

 +6        SET LRFLAG=$GET(LRFLAG)

 +7        KILL OUT

 +8        SET LRX=$$NAME^XUAF4(LR4)

           SET CLIA=$$ID^XUAF4("CLIA",LR4)

 +9       ;_LRX

           SET A(1)="Reporting Lab:"

 +10       SET A(2)=LRX

 +11       IF 'LRFLAG

               SET A(1,"F")="!!?2"

               SET A(2,"F")="!?2"

 +12       IF CLIA'=""

               Begin DoDot:1

 +13               SET X="[CLIA# "_CLIA_"]"

 +14               IF $LENGTH(A(2))+$LENGTH(X)+1>$GET(IOM,80)

                       SET A(2.5)=X

                       if 'LRFLAG

                           SET A(2.5,"F")="!?17"

 +15              IF '$TEST

                       SET A(2)=A(2)_" "_X