BLRAG09F ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ;
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
;print Shipping Manifest LA7SMP
;
DEV(BLRDEV) ; Print Shipping Manifest
; requires:
; LA7SCFG = Shipping Configuration pointer to file 62.9
; LA7SM = Shipping Manifest pointer to file 62.8
;
; Determine if bar codes on manifest
S LA7SBC=$$GET1^DIQ(62.9,+LA7SCFG_",",.09,"I")
; If not in shipping status then don't print, save paper
I $P($G(^LAHM(62.8,+LA7SM,0)),"^",3)<4 S LA7SBC=0
;
S BLRDEV=$$DEV^BLRAG02(BLRDEV)
;S %ZIS="MQ" D ^%ZIS
S:POP BLREF="-1^Print Error"
I POP S BLREF="-1^Print Error" Q
I BLRDEV=-1 S BLREF=-"1^Print Error" Q
Q:POP
DQ ;
;
U BLRDEV
;
S LA7SM(0)=$G(^LAHM(62.8,+LA7SM,0))
S LA7SCFG=+$P(LA7SM(0),"^",2),LA7SCFG(0)=$G(^LAHM(62.9,LA7SCFG,0))
S (LA7DC,LA7EXIT,LA7END,LA7ITEM,LA7PAGE,LA7SMR,LA760,LA762801)=0
S (LA7FSITE,LA7TSITE)=""
;
; Get collecting site's names and station numbers
D GETSITE^LA7SMP($P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3),.LA7FSITE,.LA7TSITE)
;
; Flag - skip if accession deleted
S LA7SKIP=0
; Check manifest for missing info.
I $G(LA7CHK)="" S LA7CHK=1
;
S LA7NOW=$$HTE^XLFDT($H,"1M")
; Manifest status
S LA7SMST=$P(LA7SM(0),"^",3)
I LA7SMST=4 D
. ; Get shipping date
. S LA7SDT=$$SMED^LA7SMU(LA7SM,"SM05")
. ; Flag to print receipt.
. I IOST["P-" S LA7SMR=$P(LA7SCFG(0),"^",10)
;
; Set barcode flag to "off"
I LA7SBC,IOST'["P-" S LA7SBC=0
;
S $P(LA7SMST,"^",2)=$$EXTERNAL^DILFD(62.8,.03,"",LA7SMST)
S LA7LINE="",$P(LA7LINE,"-",IOM)=""
S LA7SVIA=$S($P(LA7SM(0),"^",4):$$GET1^DIQ(62.92,$P(LA7SM(0),"^",4)_",",.01),1:"None Specified")
;
F S LA762801=$O(^LAHM(62.8,+LA7SM,10,LA762801)) Q:'LA762801 D
. F I=0,1,2 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10,LA762801,I))
. I $P(LA762801(0),"^",8)=0 Q ; Test previously "removed".
. S LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
. I LA7SKIP,LA7SKIP<3 Q ; Accession/test deleted
. I $G(LA7CHK) D CHKREQI^LA7SM2(+LA7SM,LA762801)
. ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^",9),$P(LA762801(0),"^",5),LA762801)="" ;ihs/cmi/maw 8/4/2010 orig line
. S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^"),$P(LA762801(0),"^",5),LA762801)="" ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
. ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^"),$$GETORDA^LA7VORM1($P(LA762801(0),"^",5)),LA762801)="" ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
. D BUILDRI^LA7SM2
;
S (LA7SCOND,LA7SCONT,LA7UID)=""
;
I '$D(^TMP("BLRSM",$J)) D
. D HED^LA7SMP0
. W !!,$$CJ^XLFSTR("No entries to print",IOM)
;
S BLRS3="" F S BLRS3=$O(^TMP("BLRSM",$J,BLRS3)) Q:BLRS3="" D Q:LA7EXIT
.S BLRS4="" F S BLRS4=$O(^TMP("BLRSM",$J,BLRS3,BLRS4)) Q:BLRS4="" D Q:LA7EXIT
..S BLRS5="" F S BLRS5=$O(^TMP("BLRSM",$J,BLRS3,BLRS4,BLRS5)) Q:BLRS5="" D Q:LA7EXIT
...S BLRS6="" F S BLRS6=$O(^TMP("BLRSM",$J,BLRS3,BLRS4,BLRS5,BLRS6)) Q:BLRS6="" D Q:LA7EXIT
....I LA7EXIT Q
....I $L(LA7UID),LA7UID'=BLRS5 W !,LA7LINE
....I LA7SCOND'=BLRS3!(LA7SCONT'=BLRS4) D Q:LA7EXIT
.....I $L(LA7UID),LA7UID=BLRS5 W !,LA7LINE
.....I LA7PAGE,+LA7SMST'=4 W ! D WARN^LA7SMP0
.....S LA7SCOND=BLRS3,LA7SCONT=BLRS4
.....D HED^LA7SMP0 S LA7UID=""
....S LA762801=BLRS6
....F I=0,.1,2,5 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10,LA762801,I))
....S LA760=+$P(LA762801(0),"^",2) ; File #60 test ien
....I LA7UID'=BLRS5 D Q:LA7EXIT
.....S LA7UID=BLRS5
.....S LRDFN=+LA762801(0) D PTID^LA7SMP0
.....S BLRC3=LA7UID
.....S BLRC4="" F S BLRC4=$O(^LRO(68,"C",BLRC3,BLRC4)) Q:BLRC4="" D
......S BLRC5="" F S BLRC5=$O(^LRO(68,"C",BLRC3,BLRC4,BLRC5)) Q:BLRC5="" D
.......S BLRC6="" F S BLRC6=$O(^LRO(68,"C",BLRC3,BLRC4,BLRC5,BLRC6)) Q:BLRC6="" D
........I LA7UID'=BLRC3 S LA7SKIP=1 ; Skip - UID missing.
........S LA7AA=+BLRC4,LA7AD=+BLRC5,LA7AN=+BLRC6
........S LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
........I LA7SKIP,LA7SKIP<3 Q ; Skip - accession/test deleted.
........S LA7ACC=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.2),"Accession not available"),"^")
........S X=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0),"Not available"),U,8)
........S LA7PROV=$S(X>0:X,1:"")_"^"_$S(X>0:$$PRAC^LRX(X),1:X)
........S LA7CDT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3),"Not available"),U,1)
........S LA7SPEC=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,1,0),"Not available")
........I LA7SPEC S LA7SPEC(0)=$G(^LAB(61,+LA7SPEC,0))
........E S LA7SPEC(0)="Specimen info not assigned"
........S LA762=$P(LA7SPEC,"^",2)
........I LA762 S LA762(0)=$G(^LAB(62,LA762,0))
........E S LA762(0)="Collection info not assigned"
........S LA7ITEM=LA7ITEM+1
........I ($Y+12)>IOSL D Q:LA7EXIT
.........W !
.........I +LA7SMST'=4 D WARN^LA7SMP0
.........D HED^LA7SMP0
........D SH^LA7SMP0
....I LA7SKIP,LA7SKIP<3 Q ; Skip - accession/test deleted.
....I ($Y+6)>IOSL D Q:LA7EXIT
.....W !,LA7LINE
.....I +LA7SMST'=4 W ! D WARN^LA7SMP0
.....D HED^LA7SMP0 Q:LA7EXIT
.....S LA7DC=1 D SH^LA7SMP0
....;cmi/maw 7/6/2010 add insurance information here
....D PRT^LA7VQINS(LA7UID)
....W !,?11,$E(LA7LINE,1,41)
....W !,?11,$P(^LAB(60,LA760,0),"^",1),?43,$P(LA7SPEC(0),"^")
....I +LA7SMST'=4 D
.....N LA7TCOST
.....S LA7TCOST=$$GET1^DIQ(60,LA760_",",1,"E") Q:'$L(LA7TCOST)
.....W:$X>(IOM-15) ! W ?(IOM-15)," Cost: $",$FN(LA7TCOST,",",2)
....I LA762801(.1)'="" D
.....K ^UTILITY($J),LA7CMT
.....S DIWL=1,DIWR=IOM-13,DIWF=""
.....S X="Relevant clinical information: "_LA762801(.1) D ^DIWP
.....M LA7CMT=^UTILITY($J,"W",DIWL)
.....W ! D CMT^LA7SMP0 W !
....W ! D OCMT^LA7SMP0(LA7UID) W ! ;ihs/cmi/maw 07/26/2011 for ref lab
....;W !,?13,"VA NLT Code [Name]: " ;ihs/cmi/maw 8/4/2010 not wanted
....;S LA7NLT=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",1) ; NLT code. ;ihs/cmi/maw 8/4/2010 not wanted
....;W $S($L(LA7NLT):LA7NLT,1:"*** None specified ***") ;ihs/cmi/maw 8/4/2010 not wanted
....;S LA7NLTN="" ;ihs/cmi/maw 8/4/2010 not wanted
....;I $L(LA7NLT) S LA7NLTN=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",.01) ; NLT code test name. ;ihs/cmi/maw 8/4/2010 not wanted
....;I $L(LA7NLTN) W:($X+$L(LA7NLTN)+3)>IOM !,?32 W " [",LA7NLTN,"]" ;ihs/cmi/maw 8/4/2010 not wanted
....I $P(LA7SM(0),"^",5) D ; Print non-VA test code info
.....N LA7X,LA7Y,LA7Z
.....S LA7X=$P($G(^DIC(4,+$P(LA7SCFG(0),"^",3),0),"UNKNOWN"),"^",1)_" Order Code [Name]: "
.....W !,?11,LA7X,$S($L($P(LA762801(5),"^")):$P(LA762801(5),"^"),1:"*** None specified ***")," "
.....S LA7Y="["_$S($L($P(LA762801(5),"^",2)):$P(LA762801(5),"^",2),1:"*** None specified ***")_"]"
.....I $L(LA7Y)<(IOM-$X) D Q
......W LA7Y
......D AO^LA7VQINS(LA7UID)
.....S LA7X=IOM-$X W $E(LA7Y,1,LA7X)
.....;lets try adding ask at order questions here
.....D AO^LA7VQINS(LA7UID)
.....S LA7Y=$E(LA7Y,LA7X+1,$L(LA7Y)),LA7Z=IOM-11
.....F S LA7X=$E(LA7Y,1,LA7Z) Q:LA7X="" W !,?11,LA7X S LA7Y=$E(LA7Y,LA7Z+1,$L(LA7Y))
;
I LA7EXIT Q
;
W !,LA7LINE,!!,"End of Shipping Manifest"
;
I +LA7SMST'=4 D
. I IOM<131 W !
. D WARN^LA7SMP0
;
; Print shipping manifest receipt.
I LA7SMR D
. ; Flag that we're now printing receipt
. S $P(LA7SMR,"^",2)=1
. D HED^LA7SMP0
. W !!,"Number of specimens: ",LA7ITEM
. W !!,"Receipted by: ",$$REPEAT^XLFSTR("_",40)
. W !!," Date/time: ",$$REPEAT^XLFSTR("_",20)
;
; Print error listing if any.
I $O(LA7ERR(""))'="" D
.S $P(LA7SMR,"^",2)=2 ; Flag printing of error listing
.D HED^LA7SMP0
.S LA7I=0
.F S LA7I=$O(LA7ERR(LA7I)) Q:LA7I="" D Q:LA7EXIT
..I ($Y+6)>IOSL D HED^LA7SMP0 Q:LA7EXIT
..W LA7ERR(LA7I)
..S BLRS3=LA7I
..S BLRS4=$P(LA7SM,"^",1)
..S BLRS5="" F S BLRS5=$O(^TMP("LA7ERR",$J,BLRS3,BLRS4,BLRS5)) Q:BLRS5="" D Q:LA7EXIT
...S BLRS6="" F S BLRS5=$O(^TMP("LA7ERR",$J,BLRS3,BLRS4,BLRS5,BLRS6)) Q:BLRS6="" D Q:LA7EXIT
....I ($Y+6)>IOSL D HED^LA7SMP0 Q:LA7EXIT W LA7ERR(LA7I)," (Cont'd)"
....;W !,?10,"UID: ",BLRS5," Test: ",$$GET1^DIQ(60,BLRS6_",",.01)
....W !,?10,"UID: ",BLRS5," Test: ",$$TESTNAME^BLRAGUT(+BLRS6)
...W !!
;
I $D(ZTQUEUED) D END^LA7SMP0
;
Q
;
;
GETSITE(LA7X,LA7Y,LA7FS,LA7TS) ; Setup variables for ordering and host sites
;
; Call with LA7X = File #4 ordering site ien
; LA7Y = File #4 host site ien
; LA7FS = array to return collecting site info
; LA7TS = array to return host site info
;
; Get ordering site's names and station numbers
S LA7FS=$$GET1^DIQ(4,LA7X_",",.01)
I LA7FS="" S LA7FS="UNKNOWN:Entry #"_+LA7X
S LA7FS(99)=$$RETFACID^LA7VHLU2(LA7X,2,1)
I LA7FS(99)="" S LA7FS(99)="UNK: #"_+LA7X
;
; Get host site's names and station numbers
S LA7TS=$$GET1^DIQ(4,LA7Y_",",.01)
I LA7TS="" S LA7TS="UNKNOWN:Entry #"_+LA7Y
S LA7TS(99)=$$RETFACID^LA7VHLU2(LA7X,1,1)
I LA7TS(99)="" S LA7TS(99)="UNK: #"_+LA7Y
Q
;
;
ASK(LA7SM) ; Ask it user wants to print manifest.
; Call with array LA7SM = ien of 62.8^.01 field of #62.8
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S DIR(0)="YO",DIR("A")="Print Shipping Manifest",DIR("B")="NO"
D ^DIR Q:$D(DIRUT)
I Y=1 D DEV,END^LA7SMP0
;
Q
BLRAG09F ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ;
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
+2 ;print Shipping Manifest LA7SMP
+3 ;
DEV(BLRDEV) ; Print Shipping Manifest
+1 ; requires:
+2 ; LA7SCFG = Shipping Configuration pointer to file 62.9
+3 ; LA7SM = Shipping Manifest pointer to file 62.8
+4 ;
+5 ; Determine if bar codes on manifest
+6 SET LA7SBC=$$GET1^DIQ(62.9,+LA7SCFG_",",.09,"I")
+7 ; If not in shipping status then don't print, save paper
+8 IF $PIECE($GET(^LAHM(62.8,+LA7SM,0)),"^",3)<4
SET LA7SBC=0
+9 ;
+10 SET BLRDEV=$$DEV^BLRAG02(BLRDEV)
+11 ;S %ZIS="MQ" D ^%ZIS
+12 IF POP
SET BLREF="-1^Print Error"
+13 IF POP
SET BLREF="-1^Print Error"
QUIT
+14 IF BLRDEV=-1
SET BLREF=-"1^Print Error"
QUIT
+15 IF POP
QUIT
DQ ;
+1 ;
+2 USE BLRDEV
+3 ;
+4 SET LA7SM(0)=$GET(^LAHM(62.8,+LA7SM,0))
+5 SET LA7SCFG=+$PIECE(LA7SM(0),"^",2)
SET LA7SCFG(0)=$GET(^LAHM(62.9,LA7SCFG,0))
+6 SET (LA7DC,LA7EXIT,LA7END,LA7ITEM,LA7PAGE,LA7SMR,LA760,LA762801)=0
+7 SET (LA7FSITE,LA7TSITE)=""
+8 ;
+9 ; Get collecting site's names and station numbers
+10 DO GETSITE^LA7SMP($PIECE(LA7SCFG(0),"^",2),$PIECE(LA7SCFG(0),"^",3),.LA7FSITE,.LA7TSITE)
+11 ;
+12 ; Flag - skip if accession deleted
+13 SET LA7SKIP=0
+14 ; Check manifest for missing info.
+15 IF $GET(LA7CHK)=""
SET LA7CHK=1
+16 ;
+17 SET LA7NOW=$$HTE^XLFDT($HOROLOG,"1M")
+18 ; Manifest status
+19 SET LA7SMST=$PIECE(LA7SM(0),"^",3)
+20 IF LA7SMST=4
Begin DoDot:1
+21 ; Get shipping date
+22 SET LA7SDT=$$SMED^LA7SMU(LA7SM,"SM05")
+23 ; Flag to print receipt.
+24 IF IOST["P-"
SET LA7SMR=$PIECE(LA7SCFG(0),"^",10)
End DoDot:1
+25 ;
+26 ; Set barcode flag to "off"
+27 IF LA7SBC
IF IOST'["P-"
SET LA7SBC=0
+28 ;
+29 SET $PIECE(LA7SMST,"^",2)=$$EXTERNAL^DILFD(62.8,.03,"",LA7SMST)
+30 SET LA7LINE=""
SET $PIECE(LA7LINE,"-",IOM)=""
+31 SET LA7SVIA=$SELECT($PIECE(LA7SM(0),"^",4):$$GET1^DIQ(62.92,$PIECE(LA7SM(0),"^",4)_",",.01),1:"None Specified")
+32 ;
+33 FOR
SET LA762801=$ORDER(^LAHM(62.8,+LA7SM,10,LA762801))
IF 'LA762801
QUIT
Begin DoDot:1
+34 FOR I=0,1,2
SET LA762801(I)=$GET(^LAHM(62.8,+LA7SM,10,LA762801,I))
+35 ; Test previously "removed".
IF $PIECE(LA762801(0),"^",8)=0
QUIT
+36 SET LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
+37 ; Accession/test deleted
IF LA7SKIP
IF LA7SKIP<3
QUIT
+38 IF $GET(LA7CHK)
DO CHKREQI^LA7SM2(+LA7SM,LA762801)
+39 ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^",9),$P(LA762801(0),"^",5),LA762801)="" ;ihs/cmi/maw 8/4/2010 orig line
+40 ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
SET ^TMP("BLRSM",$JOB,+$PIECE(LA762801(0),"^",7),+$PIECE(LA762801(0),"^"),$PIECE(LA762801(0),"^",5),LA762801)=""
+41 ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^"),$$GETORDA^LA7VORM1($P(LA762801(0),"^",5)),LA762801)="" ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
+42 DO BUILDRI^LA7SM2
End DoDot:1
+43 ;
+44 SET (LA7SCOND,LA7SCONT,LA7UID)=""
+45 ;
+46 IF '$DATA(^TMP("BLRSM",$JOB))
Begin DoDot:1
+47 DO HED^LA7SMP0
+48 WRITE !!,$$CJ^XLFSTR("No entries to print",IOM)
End DoDot:1
+49 ;
+50 SET BLRS3=""
FOR
SET BLRS3=$ORDER(^TMP("BLRSM",$JOB,BLRS3))
IF BLRS3=""
QUIT
Begin DoDot:1
+51 SET BLRS4=""
FOR
SET BLRS4=$ORDER(^TMP("BLRSM",$JOB,BLRS3,BLRS4))
IF BLRS4=""
QUIT
Begin DoDot:2
+52 SET BLRS5=""
FOR
SET BLRS5=$ORDER(^TMP("BLRSM",$JOB,BLRS3,BLRS4,BLRS5))
IF BLRS5=""
QUIT
Begin DoDot:3
+53 SET BLRS6=""
FOR
SET BLRS6=$ORDER(^TMP("BLRSM",$JOB,BLRS3,BLRS4,BLRS5,BLRS6))
IF BLRS6=""
QUIT
Begin DoDot:4
+54 IF LA7EXIT
QUIT
+55 IF $LENGTH(LA7UID)
IF LA7UID'=BLRS5
WRITE !,LA7LINE
+56 IF LA7SCOND'=BLRS3!(LA7SCONT'=BLRS4)
Begin DoDot:5
+57 IF $LENGTH(LA7UID)
IF LA7UID=BLRS5
WRITE !,LA7LINE
+58 IF LA7PAGE
IF +LA7SMST'=4
WRITE !
DO WARN^LA7SMP0
+59 SET LA7SCOND=BLRS3
SET LA7SCONT=BLRS4
+60 DO HED^LA7SMP0
SET LA7UID=""
End DoDot:5
IF LA7EXIT
QUIT
+61 SET LA762801=BLRS6
+62 FOR I=0,.1,2,5
SET LA762801(I)=$GET(^LAHM(62.8,+LA7SM,10,LA762801,I))
+63 ; File #60 test ien
SET LA760=+$PIECE(LA762801(0),"^",2)
+64 IF LA7UID'=BLRS5
Begin DoDot:5
+65 SET LA7UID=BLRS5
+66 SET LRDFN=+LA762801(0)
DO PTID^LA7SMP0
+67 SET BLRC3=LA7UID
+68 SET BLRC4=""
FOR
SET BLRC4=$ORDER(^LRO(68,"C",BLRC3,BLRC4))
IF BLRC4=""
QUIT
Begin DoDot:6
+69 SET BLRC5=""
FOR
SET BLRC5=$ORDER(^LRO(68,"C",BLRC3,BLRC4,BLRC5))
IF BLRC5=""
QUIT
Begin DoDot:7
+70 SET BLRC6=""
FOR
SET BLRC6=$ORDER(^LRO(68,"C",BLRC3,BLRC4,BLRC5,BLRC6))
IF BLRC6=""
QUIT
Begin DoDot:8
+71 ; Skip - UID missing.
IF LA7UID'=BLRC3
SET LA7SKIP=1
+72 SET LA7AA=+BLRC4
SET LA7AD=+BLRC5
SET LA7AN=+BLRC6
+73 SET LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
+74 ; Skip - accession/test deleted.
IF LA7SKIP
IF LA7SKIP<3
QUIT
+75 SET LA7ACC=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.2),"Accession not available"),"^")
+76 SET X=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0),"Not available"),U,8)
+77 SET LA7PROV=$SELECT(X>0:X,1:"")_"^"_$SELECT(X>0:$$PRAC^LRX(X),1:X)
+78 SET LA7CDT=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3),"Not available"),U,1)
+79 SET LA7SPEC=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,1,0),"Not available")
+80 IF LA7SPEC
SET LA7SPEC(0)=$GET(^LAB(61,+LA7SPEC,0))
+81 IF '$TEST
SET LA7SPEC(0)="Specimen info not assigned"
+82 SET LA762=$PIECE(LA7SPEC,"^",2)
+83 IF LA762
SET LA762(0)=$GET(^LAB(62,LA762,0))
+84 IF '$TEST
SET LA762(0)="Collection info not assigned"
+85 SET LA7ITEM=LA7ITEM+1
+86 IF ($Y+12)>IOSL
Begin DoDot:9
+87 WRITE !
+88 IF +LA7SMST'=4
DO WARN^LA7SMP0
+89 DO HED^LA7SMP0
End DoDot:9
IF LA7EXIT
QUIT
+90 DO SH^LA7SMP0
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
IF LA7EXIT
QUIT
+91 ; Skip - accession/test deleted.
IF LA7SKIP
IF LA7SKIP<3
QUIT
+92 IF ($Y+6)>IOSL
Begin DoDot:5
+93 WRITE !,LA7LINE
+94 IF +LA7SMST'=4
WRITE !
DO WARN^LA7SMP0
+95 DO HED^LA7SMP0
IF LA7EXIT
QUIT
+96 SET LA7DC=1
DO SH^LA7SMP0
End DoDot:5
IF LA7EXIT
QUIT
+97 ;cmi/maw 7/6/2010 add insurance information here
+98 DO PRT^LA7VQINS(LA7UID)
+99 WRITE !,?11,$EXTRACT(LA7LINE,1,41)
+100 WRITE !,?11,$PIECE(^LAB(60,LA760,0),"^",1),?43,$PIECE(LA7SPEC(0),"^")
+101 IF +LA7SMST'=4
Begin DoDot:5
+102 NEW LA7TCOST
+103 SET LA7TCOST=$$GET1^DIQ(60,LA760_",",1,"E")
IF '$LENGTH(LA7TCOST)
QUIT
+104 IF $X>(IOM-15)
WRITE !
WRITE ?(IOM-15)," Cost: $",$FNUMBER(LA7TCOST,",",2)
End DoDot:5
+105 IF LA762801(.1)'=""
Begin DoDot:5
+106 KILL ^UTILITY($JOB),LA7CMT
+107 SET DIWL=1
SET DIWR=IOM-13
SET DIWF=""
+108 SET X="Relevant clinical information: "_LA762801(.1)
DO ^DIWP
+109 MERGE LA7CMT=^UTILITY($JOB,"W",DIWL)
+110 WRITE !
DO CMT^LA7SMP0
WRITE !
End DoDot:5
+111 ;ihs/cmi/maw 07/26/2011 for ref lab
WRITE !
DO OCMT^LA7SMP0(LA7UID)
WRITE !
+112 ;W !,?13,"VA NLT Code [Name]: " ;ihs/cmi/maw 8/4/2010 not wanted
+113 ;S LA7NLT=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",1) ; NLT code. ;ihs/cmi/maw 8/4/2010 not wanted
+114 ;W $S($L(LA7NLT):LA7NLT,1:"*** None specified ***") ;ihs/cmi/maw 8/4/2010 not wanted
+115 ;S LA7NLTN="" ;ihs/cmi/maw 8/4/2010 not wanted
+116 ;I $L(LA7NLT) S LA7NLTN=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",.01) ; NLT code test name. ;ihs/cmi/maw 8/4/2010 not wanted
+117 ;I $L(LA7NLTN) W:($X+$L(LA7NLTN)+3)>IOM !,?32 W " [",LA7NLTN,"]" ;ihs/cmi/maw 8/4/2010 not wanted
+118 ; Print non-VA test code info
IF $PIECE(LA7SM(0),"^",5)
Begin DoDot:5
+119 NEW LA7X,LA7Y,LA7Z
+120 SET LA7X=$PIECE($GET(^DIC(4,+$PIECE(LA7SCFG(0),"^",3),0),"UNKNOWN"),"^",1)_" Order Code [Name]: "
+121 WRITE !,?11,LA7X,$SELECT($LENGTH($PIECE(LA762801(5),"^")):$PIECE(LA762801(5),"^"),1:"*** None specified ***")," "
+122 SET LA7Y="["_$SELECT($LENGTH($PIECE(LA762801(5),"^",2)):$PIECE(LA762801(5),"^",2),1:"*** None specified ***")_"]"
+123 IF $LENGTH(LA7Y)<(IOM-$X)
Begin DoDot:6
+124 WRITE LA7Y
+125 DO AO^LA7VQINS(LA7UID)
End DoDot:6
QUIT
+126 SET LA7X=IOM-$X
WRITE $EXTRACT(LA7Y,1,LA7X)
+127 ;lets try adding ask at order questions here
+128 DO AO^LA7VQINS(LA7UID)
+129 SET LA7Y=$EXTRACT(LA7Y,LA7X+1,$LENGTH(LA7Y))
SET LA7Z=IOM-11
+130 FOR
SET LA7X=$EXTRACT(LA7Y,1,LA7Z)
IF LA7X=""
QUIT
WRITE !,?11,LA7X
SET LA7Y=$EXTRACT(LA7Y,LA7Z+1,$LENGTH(LA7Y))
End DoDot:5
End DoDot:4
IF LA7EXIT
QUIT
End DoDot:3
IF LA7EXIT
QUIT
End DoDot:2
IF LA7EXIT
QUIT
End DoDot:1
IF LA7EXIT
QUIT
+131 ;
+132 IF LA7EXIT
QUIT
+133 ;
+134 WRITE !,LA7LINE,!!,"End of Shipping Manifest"
+135 ;
+136 IF +LA7SMST'=4
Begin DoDot:1
+137 IF IOM<131
WRITE !
+138 DO WARN^LA7SMP0
End DoDot:1
+139 ;
+140 ; Print shipping manifest receipt.
+141 IF LA7SMR
Begin DoDot:1
+142 ; Flag that we're now printing receipt
+143 SET $PIECE(LA7SMR,"^",2)=1
+144 DO HED^LA7SMP0
+145 WRITE !!,"Number of specimens: ",LA7ITEM
+146 WRITE !!,"Receipted by: ",$$REPEAT^XLFSTR("_",40)
+147 WRITE !!," Date/time: ",$$REPEAT^XLFSTR("_",20)
End DoDot:1
+148 ;
+149 ; Print error listing if any.
+150 IF $ORDER(LA7ERR(""))'=""
Begin DoDot:1
+151 ; Flag printing of error listing
SET $PIECE(LA7SMR,"^",2)=2
+152 DO HED^LA7SMP0
+153 SET LA7I=0
+154 FOR
SET LA7I=$ORDER(LA7ERR(LA7I))
IF LA7I=""
QUIT
Begin DoDot:2
+155 IF ($Y+6)>IOSL
DO HED^LA7SMP0
IF LA7EXIT
QUIT
+156 WRITE LA7ERR(LA7I)
+157 SET BLRS3=LA7I
+158 SET BLRS4=$PIECE(LA7SM,"^",1)
+159 SET BLRS5=""
FOR
SET BLRS5=$ORDER(^TMP("LA7ERR",$JOB,BLRS3,BLRS4,BLRS5))
IF BLRS5=""
QUIT
Begin DoDot:3
+160 SET BLRS6=""
FOR
SET BLRS5=$ORDER(^TMP("LA7ERR",$JOB,BLRS3,BLRS4,BLRS5,BLRS6))
IF BLRS6=""
QUIT
Begin DoDot:4
+161 IF ($Y+6)>IOSL
DO HED^LA7SMP0
IF LA7EXIT
QUIT
WRITE LA7ERR(LA7I)," (Cont'd)"
+162 ;W !,?10,"UID: ",BLRS5," Test: ",$$GET1^DIQ(60,BLRS6_",",.01)
+163 WRITE !,?10,"UID: ",BLRS5," Test: ",$$TESTNAME^BLRAGUT(+BLRS6)
End DoDot:4
IF LA7EXIT
QUIT
+164 WRITE !!
End DoDot:3
IF LA7EXIT
QUIT
End DoDot:2
IF LA7EXIT
QUIT
End DoDot:1
+165 ;
+166 IF $DATA(ZTQUEUED)
DO END^LA7SMP0
+167 ;
+168 QUIT
+169 ;
+170 ;
GETSITE(LA7X,LA7Y,LA7FS,LA7TS) ; Setup variables for ordering and host sites
+1 ;
+2 ; Call with LA7X = File #4 ordering site ien
+3 ; LA7Y = File #4 host site ien
+4 ; LA7FS = array to return collecting site info
+5 ; LA7TS = array to return host site info
+6 ;
+7 ; Get ordering site's names and station numbers
+8 SET LA7FS=$$GET1^DIQ(4,LA7X_",",.01)
+9 IF LA7FS=""
SET LA7FS="UNKNOWN:Entry #"_+LA7X
+10 SET LA7FS(99)=$$RETFACID^LA7VHLU2(LA7X,2,1)
+11 IF LA7FS(99)=""
SET LA7FS(99)="UNK: #"_+LA7X
+12 ;
+13 ; Get host site's names and station numbers
+14 SET LA7TS=$$GET1^DIQ(4,LA7Y_",",.01)
+15 IF LA7TS=""
SET LA7TS="UNKNOWN:Entry #"_+LA7Y
+16 SET LA7TS(99)=$$RETFACID^LA7VHLU2(LA7X,1,1)
+17 IF LA7TS(99)=""
SET LA7TS(99)="UNK: #"_+LA7Y
+18 QUIT
+19 ;
+20 ;
ASK(LA7SM) ; Ask it user wants to print manifest.
+1 ; Call with array LA7SM = ien of 62.8^.01 field of #62.8
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 ;
+5 SET DIR(0)="YO"
SET DIR("A")="Print Shipping Manifest"
SET DIR("B")="NO"
+6 DO ^DIR
IF $DATA(DIRUT)
QUIT
+7 IF Y=1
DO DEV
DO END^LA7SMP0
+8 ;
+9 QUIT
