LROW2P.m

LROW2P ;VA/SLC/TGA - PRINTS WARD COLLECT ORDER IN LAB ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LAB SERVICE;**1027,1028,1033**;NOV 01, 1997;Build 46

 ;;5.2;LAB SERVICE;**100,121,338**;NOV 01, 1997

 ;S ZTRTN="ENT^LROW2P",ZTIO=ION,ZTDTH=$H,ZTSAVE("LRSN")="",ZTSAVE("LRODT")="",ZTDESC="PRINTS WARD COLLECT ORDER" I ION]"" D ^%ZTLOAD

 S ZTRTN="ENT^LROW2P",ZTIO=ION,ZTDTH=$H,ZTSAVE("LRSN")="",ZTSAVE("LRODT")="",ZTDESC="PRINTS WARD/CLINIC COLLECT ORDER" I ION]"" D ^%ZTLOAD  ;IHS/OIRM TUC/AAB 3/20/97

 K ZTSK,ZTRTN,ZTIO,ZTDTH,ZTSAVE,ZTDESC

 Q

ENT ;

 S U="^" S:$D(ZTQUEUED) ZTREQ="@"

ENT2 ;from LRORDST, LROW2

 Q:'$D(^LRO(69,LRODT,1,LRSN,0))

 N LRSAMP,GOT,I S GOT=0

 S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1  I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1

 Q:'GOT

 S X=^LRO(69,LRODT,1,LRSN,0),LRCSS=$S($D(^(4,1)):^(1,0),1:0),LRDFN=$P(X,U),(LRSAMP,LRCS)=$P(X,U,3),LRLWC=$P(X,U,4),LRDTO=$P(X,U,5),LRPR=$P(X,U,6),LRLLOC=$P(X,U,7),LRORDTIM=$P($P(X,U,8),".",2),LRDUZ=$P(X,U,2)

 S LRCSS=$S($D(^LAB(61,+LRCSS,0)):$P(^(0),U),1:""),LRCS=$S($D(^LAB(62,+LRCS,0)):^(0),1:"")

 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),X=^DIC(LRDPF,0,"GL")_DFN_",0)",PNM=$S($D(@X):$P(@X,U),1:"UNKNOWN"),SSN=$S($D(@X):$P(@X,U,9),1:"UNKNOWN") S X=^DIC(LRDPF,0,"GL")_DFN_",.101)" S LRBED=$S($D(@X):^(.101),1:"")

 D:SSN SSN^LRU

 W !!,?23,"LABORATORY: ",^DD("SITE")  ;IHS/ANMC/CLS 08/18/96

 ;W !!,?23,$S(LRLWC="SP":"Send Patient",LRLWC="WC":"Ward Collect",LRLWC="I":"Immed Lab Collect ",1:"Lab Collect")," ORDER FOR " S Y=LRODT D DD^LRX W Y

 W !,?23,$S(LRLWC="SP":"Send Patient",LRLWC="WC":"Ward/Clinic Collect",LRLWC="I":"Immed Lab Collect ",1:"Lab Collect")," ORDER FOR " S Y=LRODT D DD^LRX W Y  ;IHS/ANMC/CLS 08/18/96 AAB/3/20/97

 W !,?23,"ORDER: ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""),?40,"LOCATION: ",LRLLOC W:$L(LRBED) "    BED: ",LRBED

 D ENTRYAUD^BLRUTIL("ENT2^LROW2P 4.0","VADM")

 I $G(DOB)="" D PT^LRX       ; IHS/OIT/MKK - LR*5.2*1028

 ; W !,PNM,?40,SSN,!,"ENTERED BY: " S X=LRDUZ D DUZ^LRX K LRDUZ W LRUSNM,?40 S Y=LRDTO D DD^LRX W Y

 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027 -- Add in HRCN, DOB & SEX

 W !!,$E(PNM,1,33),?35,$G(HRCN)

 W ?46,"DOB:" W:$G(DOB)'="" $$FMTE^XLFDT(DOB,"5DZ")

 W ?65,"SEX:",$G(SEX)

 W !,"ENTERED BY: " S X=LRDUZ D DUZ^LRX K LRDUZ W LRUSNM,?40 S Y=LRDTO D DD^LRX W Y

 ; ----- END IHS/OIT/MKK - LR*5.2*1027

 I $L(LRPR) W !,"PRACTITIONER: " W $S($D(^VA(200,LRPR,0)):$P(^(0),"^"),1:"UNKNOWN")

 I LRORDTIM S Y=LRODT_"."_LRORDTIM D DD^LRX W ?32,$S(LRLWC="I":"REQUESTED ",1:" Est.")_" Collect Time: ",Y

 W !,"Collection sample: ",$P(LRCS,U),"  ",$P(LRCS,U,3) W:$P(LRCS,U)'[LRCSS ?32," Site/Specimen: ",LRCSS

 S T=0 F  S T=$O(^LRO(69,LRODT,1,LRSN,2,T)) Q:T<1  S LRTP=^(T,0) D:'$P(LRTP,"^",11) TEST

 ;W !!!,"TIME OF COLLECTION:__________"

 W !!!,"DATE/TIME OF COLLECTION:__________"  ;IHS/ANMC/CLS 08/18/96

 I $G(LRLWC)="WC" W !!,"COLLECTED BY:_____________________________"  ;IHS/ANMC/CLS 08/18/96

 I $D(^LRO(69,LRODT,1,LRSN,6,0)) W !!,"Order comment: " F I=0:0 S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  W !?2,^(I,0)

 I $G(LRLWC)="SP" W !!,"** PLEASE BRING THIS WITH YOU TO THE LAB **",!  ;IHS/ANMC/CLS 08/18/96

 W ! W:$E(IOST)="P" @IOF D ^%ZISC Q

TEST W !,"TEST/PROCEDURE: ",$P(^LAB(60,+LRTP,0),U) S LRUR=+$P(LRTP,U,2) W:LRUR ?48,$P(^LAB(62.05,LRUR,0),U)

 I $D(^LAB(60,+LRTP,3,"B",+LRSAMP)) S X=$O(^(+LRSAMP,0)) I X,$D(^LAB(60,+LRTP,3,X,1)) N I S I=0 D

 . W !,"Ward Instructions:"

 . F  S I=$O(^LAB(60,+LRTP,3,X,1,I)) Q:I<1  W !?2,^(I,0)

 I $O(^LRO(69,LRODT,1,LRSN,2,T,1,0)) W !,"Ward Comments:"

 S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,T,1,I)) Q:I<1  W !?2,^(I,0)

 ;

 ;----- BEGIN IHS/OIT/MKK - LR*5.2*1027 -- PRINT OUT 'SIGN OR SYMPTOM' LAB POV

 S LRTPTR=$P($G(^LRO(69,LRODT,1,LRSN,2,T,0)),U)  ;TEST POINTER

 S:LRTPTR'="" LRTNAME=$P($G(^LAB(60,LRTPTR,0)),U)

 ; W !,"Sign or Symptom for test "_$G(LRTNAME)_" : ",$G(^LRO(69,LRODT,1,LRSN,2,T,9999999)),!!

 W !,"Clinical Indication for test "_$G(LRTNAME)_" : ",$G(^LRO(69,LRODT,1,LRSN,2,T,9999999)),!!    ; IHS/MSC/MKK - LR*5.2*1033

 K LRTPTR

 ;----- END IHS/OIT/MKK - LR*5.2*1027

 Q

LROW2P    ;VA/SLC/TGA - PRINTS WARD COLLECT ORDER IN LAB ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LAB SERVICE;**1027,1028,1033**;NOV 01, 1997;Build 46

 +2       ;;5.2;LAB SERVICE;**100,121,338**;NOV 01, 1997

 +3       ;S ZTRTN="ENT^LROW2P",ZTIO=ION,ZTDTH=$H,ZTSAVE("LRSN")="",ZTSAVE("LRODT")="",ZTDESC="PRINTS WARD COLLECT ORDER" I ION]"" D ^%ZTLOAD

 +4       ;IHS/OIRM TUC/AAB 3/20/97

           SET ZTRTN="ENT^LROW2P"

           SET ZTIO=ION

           SET ZTDTH=$HOROLOG

           SET ZTSAVE("LRSN")=""

           SET ZTSAVE("LRODT")=""

           SET ZTDESC="PRINTS WARD/CLINIC COLLECT ORDER"

           IF ION]""

               DO ^%ZTLOAD

 +5        KILL ZTSK,ZTRTN,ZTIO,ZTDTH,ZTSAVE,ZTDESC

 +6        QUIT 

ENT       ;

 +1        SET U="^"

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

ENT2      ;from LRORDST, LROW2

 +1        IF '$DATA(^LRO(69,LRODT,1,LRSN,0))

               QUIT 

 +2        NEW LRSAMP,GOT,I

           SET GOT=0

 +3        SET I=0

           FOR 

               SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))

               IF I<1

                   QUIT 

               IF $DATA(^(I,0))

                   IF '$PIECE(^(0),"^",11)

                       SET GOT=1

 +4        IF 'GOT

               QUIT 

 +5        SET X=^LRO(69,LRODT,1,LRSN,0)

           SET LRCSS=$SELECT($DATA(^(4,1)):^(1,0),1:0)

           SET LRDFN=$PIECE(X,U)

           SET (LRSAMP,LRCS)=$PIECE(X,U,3)

           SET LRLWC=$PIECE(X,U,4)

           SET LRDTO=$PIECE(X,U,5)

           SET LRPR=$PIECE(X,U,6)

           SET LRLLOC=$PIECE(X,U,7)

           SET LRORDTIM=$PIECE($PIECE(X,U,8),".",2)

           SET LRDUZ=$PIECE(X,U,2)

 +6        SET LRCSS=$SELECT($DATA(^LAB(61,+LRCSS,0)):$PIECE(^(0),U),1:"")

           SET LRCS=$SELECT($DATA(^LAB(62,+LRCS,0)):^(0),1:"")

 +7        SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

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

           SET X=^DIC(LRDPF,0,"GL")_DFN_",0)"

           SET PNM=$SELECT($DATA(@X):$PIECE(@X,U),1:"UNKNOWN")

           SET SSN=$SELECT($DATA(@X):$PIECE(@X,U,9),1:"UNKNOWN")

           SET X=^DIC(LRDPF,0,"GL")_DFN_",.101)"

           SET LRBED=$SELECT($DATA(@X):^(.101),1:"")

 +8        IF SSN

               DO SSN^LRU

 +9       ;IHS/ANMC/CLS 08/18/96

           WRITE !!,?23,"LABORATORY: ",^DD("SITE")

 +10      ;W !!,?23,$S(LRLWC="SP":"Send Patient",LRLWC="WC":"Ward Collect",LRLWC="I":"Immed Lab Collect ",1:"Lab Collect")," ORDER FOR " S Y=LRODT D DD^LRX W Y

 +11      ;IHS/ANMC/CLS 08/18/96 AAB/3/20/97

           WRITE !,?23,$SELECT(LRLWC="SP":"Send Patient",LRLWC="WC":"Ward/Clinic Collect",LRLWC="I":"Immed Lab Collect ",1:"Lab Collect")," ORDER FOR "

           SET Y=LRODT

           DO DD^LRX

           WRITE Y

 +12       WRITE !,?23,"ORDER: ",$SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""),?40,"LOCATION: ",LRLLOC

           IF $LENGTH(LRBED)

               WRITE "    BED: ",LRBED

 +13       DO ENTRYAUD^BLRUTIL("ENT2^LROW2P 4.0","VADM")

 +14      ; IHS/OIT/MKK - LR*5.2*1028

           IF $GET(DOB)=""

               DO PT^LRX

 +15      ; W !,PNM,?40,SSN,!,"ENTERED BY: " S X=LRDUZ D DUZ^LRX K LRDUZ W LRUSNM,?40 S Y=LRDTO D DD^LRX W Y

 +16      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027 -- Add in HRCN, DOB & SEX

 +17       WRITE !!,$EXTRACT(PNM,1,33),?35,$GET(HRCN)

 +18       WRITE ?46,"DOB:"

           IF $GET(DOB)'=""

               WRITE $$FMTE^XLFDT(DOB,"5DZ")

 +19       WRITE ?65,"SEX:",$GET(SEX)

 +20       WRITE !,"ENTERED BY: "

           SET X=LRDUZ

           DO DUZ^LRX

           KILL LRDUZ

           WRITE LRUSNM,?40

           SET Y=LRDTO

           DO DD^LRX

           WRITE Y

 +21      ; ----- END IHS/OIT/MKK - LR*5.2*1027

 +22       IF $LENGTH(LRPR)

               WRITE !,"PRACTITIONER: "

               WRITE $SELECT($DATA(^VA(200,LRPR,0)):$PIECE(^(0),"^"),1:"UNKNOWN")

 +23       IF LRORDTIM

               SET Y=LRODT_"."_LRORDTIM

               DO DD^LRX

               WRITE ?32,$SELECT(LRLWC="I":"REQUESTED ",1:" Est.")_" Collect Time: ",Y

 +24       WRITE !,"Collection sample: ",$PIECE(LRCS,U),"  ",$PIECE(LRCS,U,3)

           IF $PIECE(LRCS,U)'[LRCSS

               WRITE ?32," Site/Specimen: ",LRCSS

 +25       SET T=0

           FOR 

               SET T=$ORDER(^LRO(69,LRODT,1,LRSN,2,T))

               IF T<1

                   QUIT 

               SET LRTP=^(T,0)

               IF '$PIECE(LRTP,"^",11)

                   DO TEST

 +26      ;W !!!,"TIME OF COLLECTION:__________"

 +27      ;IHS/ANMC/CLS 08/18/96

           WRITE !!!,"DATE/TIME OF COLLECTION:__________"

 +28      ;IHS/ANMC/CLS 08/18/96

           IF $GET(LRLWC)="WC"

               WRITE !!,"COLLECTED BY:_____________________________"

 +29       IF $DATA(^LRO(69,LRODT,1,LRSN,6,0))

               WRITE !!,"Order comment: "

               FOR I=0:0

                   SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))

                   IF I<1

                       QUIT 

                   WRITE !?2,^(I,0)

 +30      ;IHS/ANMC/CLS 08/18/96

           IF $GET(LRLWC)="SP"

               WRITE !!,"** PLEASE BRING THIS WITH YOU TO THE LAB **",!

 +31       WRITE !

           IF $EXTRACT(IOST)="P"

               WRITE @IOF

           DO ^%ZISC

           QUIT 

TEST       WRITE !,"TEST/PROCEDURE: ",$PIECE(^LAB(60,+LRTP,0),U)

           SET LRUR=+$PIECE(LRTP,U,2)

           IF LRUR

               WRITE ?48,$PIECE(^LAB(62.05,LRUR,0),U)

 +1        IF $DATA(^LAB(60,+LRTP,3,"B",+LRSAMP))

               SET X=$ORDER(^(+LRSAMP,0))

               IF X

                   IF $DATA(^LAB(60,+LRTP,3,X,1))

                       NEW I

                       SET I=0

                       Begin DoDot:1

 +2                        WRITE !,"Ward Instructions:"

 +3                        FOR 

                               SET I=$ORDER(^LAB(60,+LRTP,3,X,1,I))

                               IF I<1

                                   QUIT 

                               WRITE !?2,^(I,0)

                       End DoDot:1

 +4        IF $ORDER(^LRO(69,LRODT,1,LRSN,2,T,1,0))

               WRITE !,"Ward Comments:"

 +5        SET I=0

           FOR 

               SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,T,1,I))

               IF I<1

                   QUIT 

               WRITE !?2,^(I,0)

 +6       ;

 +7       ;----- BEGIN IHS/OIT/MKK - LR*5.2*1027 -- PRINT OUT 'SIGN OR SYMPTOM' LAB POV

 +8       ;TEST POINTER

           SET LRTPTR=$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,T,0)),U)

 +9        IF LRTPTR'=""

               SET LRTNAME=$PIECE($GET(^LAB(60,LRTPTR,0)),U)

 +10      ; W !,"Sign or Symptom for test "_$G(LRTNAME)_" : ",$G(^LRO(69,LRODT,1,LRSN,2,T,9999999)),!!

 +11      ; IHS/MSC/MKK - LR*5.2*1033

           WRITE !,"Clinical Indication for test "_$GET(LRTNAME)_" : ",$GET(^LRO(69,LRODT,1,LRSN,2,T,9999999)),!!

 +12       KILL LRTPTR

 +13      ;----- END IHS/OIT/MKK - LR*5.2*1027

 +14       QUIT