LRHYLS1.m

LRHYLS1 ;DALOI/HOAK - DISPLAY ORDERS ; 10/15/10 11:25am

 ;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 31

 ;

LST1 ;

 Q:$G(LRKUNKE)=1

 D CHKPAGE

 Q:$G(LRSTOP)=1

 S LRDX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRCE=$S($D(^(.1)):^(.1),1:""),LRACC=$S($D(^(.2)):^(.2),1:"")

 Q:'$D(^LR(+LRDX,0))#2

 S LRDPF=$P(^LR(+LRDX,0),U,2),DFN=$P(^(0),U,3)

 D PT^LRX

 S (LRDLA,LRDLC,LRACO)=""

 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S Y=^(3),LRDLA=$P(Y,U,3),LRACO=$P(Y,U,6),Y=$P(Y,U) D

 . D:Y DD^LRX S LRDLC=Y,Y=LRDLA D:Y DD^LRX S LRDLA=Y

 S Y=$P(LRDX,U,4) D:Y DD^LRX S LRDTO=Y

 ; Patient:_______________ SSN:_________ DOB:________ PROVIDER:

 S LN=$G(LN)+4

 D CHKPAGE

 Q:$G(LRSTOP)

 W !,"UID: ",?11,$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))

 W !,"ACCESSION: ",$E(^LRO(68,LRAA,0),1,4)," ",$E(LRAD,4,7)," ",LRAN

 W !,"ORDER #: ",?11,LRCE

 S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)

 D DASH^LRX

 D BUILD^LRHYT2

 W "Patient: ",$E(PNM,1,12)

 W ?22,"SSN: ",$P(SSN,"-",3)

 W ?33,"DOB: ",$$DTF^LRAFUNC1(DOB)

 S LRPRAC=+$P(LRDX,"^",8)

 W ?50,"PROVIDER: ",$S($D(^VA(200,LRPRAC,0)):$P(^(0),"^"),1:LRPRAC)

 D DASH^LRX

 QUIT

 S LN=$G(LN)+6

 D CHKPAGE

 Q:$G(LRSTOP)=1

 N PRAC,PR D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC) I $O(PRAC(0)) S PR=0 F  S PR=$O(PRAC(PR)) Q:PR<1  I $D(^VA(200,PR,0)) W !?16,$P(^(0),"^")

 S X1=+$P(LRDX,U,4),X2=+$P(LRDX,U,5)

 I $D(^LRO(69,X1,1,X2,6)) D

 . W !,"  Order Comment:" S LN=LN+1

 . S LRHYI=0

 .  S LRNX0=$G(^LRO(69,X1,1,X2,0))

 . F  S LRHYI=$O(^LRO(69,X1,1,X2,6,LRHYI)) Q:LRHYI<1  I LRHYI>1 W !?11,^(LRHYI,0) S LN=LN+1 D CHKPAGE Q:$G(LRSTOP)

TSTCOM ;

 Q:$G(LRSTOP)

 S LRHYI=0

 F  S LRHYI=$O(^LRO(69,X1,1,X2,2,LRHYI)) Q:LRHYI<1  S X=^(LRHYI,0) I $P(X,"^",11) D

 . W !,"  CANCELLED TEST: ",$S($D(^LAB(60,+X,0)):$P(^(0),"^"),1:"UNKNOWN")

 . N LRURG S LRURG=+$P(X,U,2)

 . I LRURG=1!(LRURG=51) D FLASH

 . I LRURG=51 D FLASH

 . E  W " "_$E($S($D(^LAB(62.05,LRURG,0)):$P(^(0),U),1:"ROUTINE"),1,15)

 . W " by: "_$P(^VA(200,$P(X,"^",11),0),"^")

 . S LRHYI(2)=0 F  S LRHYI(2)=$O(^LRO(69,X1,1,X2,2,LRHYI,1.1,LRHYI(2))) Q:LRHYI(2)<1  I $D(^(LRHYI(2),0)) W !?3,": "_^(0) D CHKPAGE Q:$G(LRSTOP)

 I $L(LRACO) W !,"  Accession Comment: ",LRACO S LN=LN+1

 W:$L($P(LRDX,U,6,7))>1 !

 Q

FLASH ;

 I $G(LRURG)=1!(LRURG=51) D SCRNON^LRHYUTL W IOBON

 ;

 W ?20,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," "

 ;

 I $G(LRURG)=1 W IOBOFF D SCRNOFF^LRHYUTL

 ;

 QUIT

CHKPAGE ;

 Q:$G(LRSTOP)!($D(ZTQUEUED))!($E(IOST,1,2)'="C-")

 Q:$G(LN)<(IOSL-2)

 K DIR

 S DIR(0)="E"

 D ^DIR

 I $D(DUOUT)!($D(DIRUT)) S LRSTOP=1 Q

 S LREND=$G(LRSTOP)

 S LN=1

 W !

 Q

LEDI ; print LEDI information

 D LEDI^LRWRKLS1

 Q

LRHYLS1   ;DALOI/HOAK - DISPLAY ORDERS ; 10/15/10 11:25am

 +1       ;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 31

 +2       ;

LST1      ;

 +1        IF $GET(LRKUNKE)=1

               QUIT 

 +2        DO CHKPAGE

 +3        IF $GET(LRSTOP)=1

               QUIT 

 +4        SET LRDX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRCE=$SELECT($DATA(^(.1)):^(.1),1:"")

           SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"")

 +5        IF '$DATA(^LR(+LRDX,0))#2

               QUIT 

 +6        SET LRDPF=$PIECE(^LR(+LRDX,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

 +7        DO PT^LRX

 +8        SET (LRDLA,LRDLC,LRACO)=""

 +9        IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))

               SET Y=^(3)

               SET LRDLA=$PIECE(Y,U,3)

               SET LRACO=$PIECE(Y,U,6)

               SET Y=$PIECE(Y,U)

               Begin DoDot:1

 +10               IF Y

                       DO DD^LRX

                   SET LRDLC=Y

                   SET Y=LRDLA

                   IF Y

                       DO DD^LRX

                   SET LRDLA=Y

               End DoDot:1

 +11       SET Y=$PIECE(LRDX,U,4)

           IF Y

               DO DD^LRX

           SET LRDTO=Y

 +12      ; Patient:_______________ SSN:_________ DOB:________ PROVIDER:

 +13       SET LN=$GET(LN)+4

 +14       DO CHKPAGE

 +15       IF $GET(LRSTOP)

               QUIT 

 +16       WRITE !,"UID: ",?11,$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))

 +17       WRITE !,"ACCESSION: ",$EXTRACT(^LRO(68,LRAA,0),1,4)," ",$EXTRACT(LRAD,4,7)," ",LRAN

 +18       WRITE !,"ORDER #: ",?11,LRCE

 +19       SET LRUID=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)

 +20       DO DASH^LRX

 +21       DO BUILD^LRHYT2

 +22       WRITE "Patient: ",$EXTRACT(PNM,1,12)

 +23       WRITE ?22,"SSN: ",$PIECE(SSN,"-",3)

 +24       WRITE ?33,"DOB: ",$$DTF^LRAFUNC1(DOB)

 +25       SET LRPRAC=+$PIECE(LRDX,"^",8)

 +26       WRITE ?50,"PROVIDER: ",$SELECT($DATA(^VA(200,LRPRAC,0)):$PIECE(^(0),"^"),1:LRPRAC)

 +27       DO DASH^LRX

 +28       QUIT 

 +29       SET LN=$GET(LN)+6

 +30       DO CHKPAGE

 +31       IF $GET(LRSTOP)=1

               QUIT 

 +32       NEW PRAC,PR

           DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)

           IF $ORDER(PRAC(0))

               SET PR=0

               FOR 

                   SET PR=$ORDER(PRAC(PR))

                   IF PR<1

                       QUIT 

                   IF $DATA(^VA(200,PR,0))

                       WRITE !?16,$PIECE(^(0),"^")

 +33       SET X1=+$PIECE(LRDX,U,4)

           SET X2=+$PIECE(LRDX,U,5)

 +34       IF $DATA(^LRO(69,X1,1,X2,6))

               Begin DoDot:1

 +35               WRITE !,"  Order Comment:"

                   SET LN=LN+1

 +36               SET LRHYI=0

 +37               SET LRNX0=$GET(^LRO(69,X1,1,X2,0))

 +38               FOR 

                       SET LRHYI=$ORDER(^LRO(69,X1,1,X2,6,LRHYI))

                       IF LRHYI<1

                           QUIT 

                       IF LRHYI>1

                           WRITE !?11,^(LRHYI,0)

                           SET LN=LN+1

                           DO CHKPAGE

                           IF $GET(LRSTOP)

                               QUIT 

               End DoDot:1

TSTCOM    ;

 +1        IF $GET(LRSTOP)

               QUIT 

 +2        SET LRHYI=0

 +3        FOR 

               SET LRHYI=$ORDER(^LRO(69,X1,1,X2,2,LRHYI))

               IF LRHYI<1

                   QUIT 

               SET X=^(LRHYI,0)

               IF $PIECE(X,"^",11)

                   Begin DoDot:1

 +4                    WRITE !,"  CANCELLED TEST: ",$SELECT($DATA(^LAB(60,+X,0)):$PIECE(^(0),"^"),1:"UNKNOWN")

 +5                    NEW LRURG

                       SET LRURG=+$PIECE(X,U,2)

 +6                    IF LRURG=1!(LRURG=51)

                           DO FLASH

 +7                    IF LRURG=51

                           DO FLASH

 +8                   IF '$TEST

                           WRITE " "_$EXTRACT($SELECT($DATA(^LAB(62.05,LRURG,0)):$PIECE(^(0),U),1:"ROUTINE"),1,15)

 +9                    WRITE " by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")

 +10                   SET LRHYI(2)=0

                       FOR 

                           SET LRHYI(2)=$ORDER(^LRO(69,X1,1,X2,2,LRHYI,1.1,LRHYI(2)))

                           IF LRHYI(2)<1

                               QUIT 

                           IF $DATA(^(LRHYI(2),0))

                               WRITE !?3,": "_^(0)

                               DO CHKPAGE

                               IF $GET(LRSTOP)

                                   QUIT 

                   End DoDot:1

 +11       IF $LENGTH(LRACO)

               WRITE !,"  Accession Comment: ",LRACO

               SET LN=LN+1

 +12       IF $LENGTH($PIECE(LRDX,U,6,7))>1

               WRITE !

 +13       QUIT 

FLASH     ;

 +1        IF $GET(LRURG)=1!(LRURG=51)

               DO SCRNON^LRHYUTL

               WRITE IOBON

 +2       ;

 +3        WRITE ?20,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "

 +4       ;

 +5        IF $GET(LRURG)=1

               WRITE IOBOFF

               DO SCRNOFF^LRHYUTL

 +6       ;

 +7        QUIT 

CHKPAGE   ;

 +1        IF $GET(LRSTOP)!($DATA(ZTQUEUED))!($EXTRACT(IOST,1,2)'="C-")

               QUIT 

 +2        IF $GET(LN)<(IOSL-2)

               QUIT 

 +3        KILL DIR

 +4        SET DIR(0)="E"

 +5        DO ^DIR

 +6        IF $DATA(DUOUT)!($DATA(DIRUT))

               SET LRSTOP=1

               QUIT 

 +7        SET LREND=$GET(LRSTOP)

 +8        SET LN=1

 +9        WRITE !

 +10       QUIT 

LEDI      ; print LEDI information

 +1        DO LEDI^LRWRKLS1

 +2        QUIT