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
Q
;
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
Q
;
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
Q
;
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 ;
