Routine: LA7CSHL

LA7CSHL ;ihs/cmi/maw - Send outbound ambulatory or public health message ; 22-Oct-2013 09:22 ; MAW

 ;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997

MAIN ;-- this is the main routine driver

 S ACC=$$ACC()

 Q:'ACC

 I '$O(^LRO(68,"C",ACC,0)) D  Q

 . W !,"Accession not on file"

 D GET(ACC)

 D UYEXPORT^BLRCCPED(ACC)  ;mark as exported

 K LA76249

ACC() ;-- ask for the accession

 S DIR(0)="F0^1:10",DIR("A")="Please enter the UID"

 D ^DIR

 Q:$D(DIRUT) ""

 Q $G(Y)

GET(AC) ;-- get the data needed for the call

 ;need LRAA,LRAD,LRAN,LRIDT,LRSS,LRDFN,LRSPEC, array of tests

 N LA7RT,LDA,CNT,AA,AD,AN,LDFN,IDT,SPEC,SB,SAMP

 S CNT=1

 S LA7RT=$Q(^LRO(68,"C",AC))

 S AA=$QS(LA7RT,4)

 S AD=$QS(LA7RT,5)

 S AN=$QS(LA7RT,6)

 S LDFN=$P($G(^LRO(68,AA,1,AD,1,AN,0)),U)

 S IDT=$P($G(^LRO(68,AA,1,AD,1,AN,3)),U,5)

 S SPEC=$P($G(^LR(LDFN,"CH",IDT,0)),U,5)

 S SAMP=$$SAMP(AA,AD,AN,SPEC)

 S LDA=0 F  S LDA=$O(^LR(LDFN,"CH",IDT,LDA)) Q:'LDA  D

 . S SB(CNT)=LDA

 . S CNT=CNT+1

 D QUEMU2^LA7CHDR(AC,AA,AD,AN,IDT,"",LDFN,SPEC,SAMP,.SB)

 N LA7DIR,LA7FILE

 S LA7DIR=$P($G(^BLRSITE(DUZ(2),"RL")),U,5)

 I $G(LA7DIR)="" S LA7DIR=$P($G(^XTV(8989.3,DUZ(2),"DEV")),U)

 I $G(LA7DIR)="" W !,"No Export Directory Set" H 3 Q

 ;S LA7DIR="e:\ehr\temp\"

 ;S LA7DIR="Q:\reflab\"

 S LA7FILE="RefLabExport"_AC_DT_LA76249_".txt"

 D WRITE(LA76249,LA7DIR,LA7FILE)

 W !,"Message exported to "_LA7DIR_LA7FILE H 2

SAMP(A,D,N,SPC) ;-- get collection sample

 N SAM,SDA

 S SAM=""

 S SDA=0 F  S SDA=$O(^LRO(68,A,1,D,1,N,5,SDA)) Q:'SDA!($G(SAM))  D

 . I $P($G(^LRO(68,A,1,D,1,N,5,SDA,0)),U)=SPC D  Q

 .. S SAM=$P($G(^LRO(68,A,1,D,1,N,5,SDA,0)),U,2)

 Q SAM

WRITE(LA76249,DIR,FILE) ;-- write out the file

 S Y=$$OPEN^%ZISH(DIR,FILE,"W")

 N BDA,SEG,SEGA

 S SEG="",SEGA=""

 S BDA=0 F  S BDA=$O(^LAHM(62.49,LA76249,150,BDA)) Q:'BDA  D

 . S SEG=$G(^LAHM(62.49,LA76249,150,BDA,0))

 . I SEG="" D  Q

 . .I SEGA]"" U IO W SEGA,!

 . .S SEGA=""

 . S SEGA=SEGA_SEG

 D ^%ZISC

LA7CSHL   ;ihs/cmi/maw - Send outbound ambulatory or public health message ; 22-Oct-2013 09:22 ; MAW

 +1       ;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997

 +2       ;

MAIN      ;-- this is the main routine driver

 +1        SET ACC=$$ACC()

 +2        IF 'ACC

               QUIT

 +3        IF '$ORDER(^LRO(68,"C",ACC,0))

               Begin DoDot:1

 +4                WRITE !,"Accession not on file"

               End DoDot:1

               QUIT

 +5        DO GET(ACC)

 +6       ;mark as exported

           DO UYEXPORT^BLRCCPED(ACC)

 +7        KILL LA76249

 +8        QUIT

 +9       ;

ACC()     ;-- ask for the accession

 +1        SET DIR(0)="F0^1:10"

           SET DIR("A")="Please enter the UID"

 +2        DO ^DIR

 +3        IF $DATA(DIRUT)

               QUIT ""

 +4        QUIT $GET(Y)

 +5       ;

GET(AC)   ;-- get the data needed for the call

 +1       ;need LRAA,LRAD,LRAN,LRIDT,LRSS,LRDFN,LRSPEC, array of tests

 +2        NEW LA7RT,LDA,CNT,AA,AD,AN,LDFN,IDT,SPEC,SB,SAMP

 +3        SET CNT=1

 +4        SET LA7RT=$QUERY(^LRO(68,"C",AC))

 +5        SET AA=$QSUBSCRIPT(LA7RT,4)

 +6        SET AD=$QSUBSCRIPT(LA7RT,5)

 +7        SET AN=$QSUBSCRIPT(LA7RT,6)

 +8        SET LDFN=$PIECE($GET(^LRO(68,AA,1,AD,1,AN,0)),U)

 +9        SET IDT=$PIECE($GET(^LRO(68,AA,1,AD,1,AN,3)),U,5)

 +10       SET SPEC=$PIECE($GET(^LR(LDFN,"CH",IDT,0)),U,5)

 +11       SET SAMP=$$SAMP(AA,AD,AN,SPEC)

 +12       SET LDA=0

FOR

               SET LDA=$ORDER(^LR(LDFN,"CH",IDT,LDA))

               IF 'LDA

                   QUIT

               Begin DoDot:1

 +13               SET SB(CNT)=LDA

 +14               SET CNT=CNT+1

               End DoDot:1

 +15       DO QUEMU2^LA7CHDR(AC,AA,AD,AN,IDT,"",LDFN,SPEC,SAMP,.SB)

 +16       NEW LA7DIR,LA7FILE

 +17       SET LA7DIR=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,5)

 +18       IF $GET(LA7DIR)=""

               SET LA7DIR=$PIECE($GET(^XTV(8989.3,DUZ(2),"DEV")),U)

 +19       IF $GET(LA7DIR)=""

               WRITE !,"No Export Directory Set"

               HANG 3

               QUIT

 +20      ;S LA7DIR="e:\ehr\temp\"

 +21      ;S LA7DIR="Q:\reflab\"

 +22       SET LA7FILE="RefLabExport"_AC_DT_LA76249_".txt"

 +23       DO WRITE(LA76249,LA7DIR,LA7FILE)

 +24       WRITE !,"Message exported to "_LA7DIR_LA7FILE

           HANG 2

 +25       QUIT

 +26      ;

SAMP(A,D,N,SPC) ;-- get collection sample

 +1        NEW SAM,SDA

 +2        SET SAM=""

 +3        SET SDA=0

FOR

               SET SDA=$ORDER(^LRO(68,A,1,D,1,N,5,SDA))

               IF 'SDA!($GET(SAM))

                   QUIT

               Begin DoDot:1

 +4                IF $PIECE($GET(^LRO(68,A,1,D,1,N,5,SDA,0)),U)=SPC

                       Begin DoDot:2

 +5                        SET SAM=$PIECE($GET(^LRO(68,A,1,D,1,N,5,SDA,0)),U,2)

                       End DoDot:2

                       QUIT

               End DoDot:1

 +6        QUIT SAM

 +7       ;

WRITE(LA76249,DIR,FILE) ;-- write out the file

 +1        SET Y=$$OPEN^%ZISH(DIR,FILE,"W")

 +2        NEW BDA,SEG,SEGA

 +3        SET SEG=""

           SET SEGA=""

 +4        SET BDA=0

FOR

               SET BDA=$ORDER(^LAHM(62.49,LA76249,150,BDA))

               IF 'BDA

                   QUIT

               Begin DoDot:1

 +5                SET SEG=$GET(^LAHM(62.49,LA76249,150,BDA,0))

 +6                IF SEG=""

                       Begin DoDot:2

 +7                        IF SEGA]""

                               USE IO

                               WRITE SEGA,!

 +8                        SET SEGA=""

                       End DoDot:2

                       QUIT

 +9                SET SEGA=SEGA_SEG

               End DoDot:1

 +10       DO ^%ZISC

 +11       QUIT

 +12      ;

LA7CSHL.m