LA7SMP ;DALOI/JMC - Shipping Manifest Print ;03/26/10 16:26
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,45,46,64,74**;Sep 27, 1994;Build 229
;
EN ; Entry point to print a shipping manifest
;
N LA7CHK,LA7SCFG,LA7EXIT,LA7PAGE,LA7QUIT,LA7SBC,LA7SM
;
D EN^DDIOL("Print Shipping Manifest","","!!")
D KILL^LA7SMP0
D INIT^LA7SMP0
I LA7QUIT D KILL^LA7SMP0 Q
S LA7SM=$$SELSM^LA7SMU(+LA7SCFG)
I LA7SM<0 D Q
. D EN^DDIOL($P(LA7SM,"^",2),"","!?5")
. D KILL^LA7SMP0
;
S LA7CHK=1 ; flag to check for missing info.
W !
D DEV
D END^LA7SMP0
Q
;
;
DEV ; Alternate entry point when user has already selected a manifest.
;
;ZEXCEPT: %ZIS,IOM,IOSL,IOST,LA7CHK,LA7EXIT,LA7PAGE,LA7SBC,LA7SCFG,LA7SM,POP,ZTQUEUED
;
; 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
I LA7SBC,$P($G(^LAHM(62.8,+LA7SM,0)),"^",3)=4 D
. N DIR,DIRUT,DTOUT,DUOUT,X,Y
. S DIR(0)="YO",DIR("A")="Print barcodes on manifest",DIR("B")="YES"
. D ^DIR
. I $D(DIRUT) S LA7EXIT=1
. I Y'=1 S LA7SBC=0
I $G(LA7EXIT) Q
;
S %ZIS="MQ" D ^%ZIS
I POP D Q
. D HOME^%ZIS
. S LA7EXIT=1
I $D(IO("Q")) D Q
. N ZTDESC,ZTDTH,ZTSK,ZTRTN,ZTIO,ZTSAVE
. S ZTRTN="DQ^LA7SMP",ZTSAVE("LA7*")="",ZTDESC="Lab Shipping Manifest Print"
. D ^%ZTLOAD,^%ZISC
. D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
. S LA7EXIT=1
DQ ;
;
U IO
;
N I,LA760,LA762,LA762801,LA7AA,LA7ACC,LA7AD,LA7AN,LA7CDT,LA7DC,LA7ERR,LA7EXIT,LA7END,LA7FSITE
N LA7I,LA7ITEM,LA7ITMID,LA7LINE,LA7NLT,LA7NLTN,LA7NOW,LA7PROV,LA7QUIT,LA7ROOT
N LA7SCFG,LA7SCOND,LA7SCONT,LA7SDT,LA7SKIP,LA7SMR,LA7SMST,LA7SPEC,LA7SVIA,LA7TSITE,LA7UID
N LRDFN
;
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
;
; 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("LA7SM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^",9),$P(LA762801(0),"^",5),LA762801)=""
. D BUILDRI^LA7SM2
;
; Setup item identifiers for printed manifest
D ITEM^LA7SMP0
;
S (LA7ITMID,LA7SCOND,LA7SCOND(0),LA7SCONT,LA7SCONT(0),LA7UID)=""
;
I '$D(^TMP("LA7SM",$J)) D
. D HED^LA7SMP0
. W !!,$$CJ^XLFSTR("No entries to print",IOM)
;
S LA7ROOT="^TMP(""LA7SM"",$J)"
F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'="LA7SM"!($QS(LA7ROOT,2)'=$J) D Q:LA7EXIT
. I LA7EXIT Q
. I LA7UID'="",LA7UID'=$QS(LA7ROOT,5) W !,LA7LINE
. I LA7SCOND'=$QS(LA7ROOT,3)!(LA7SCONT'=$QS(LA7ROOT,4)) D Q:LA7EXIT
. . I LA7UID'="",LA7UID=$QS(LA7ROOT,5) W !,LA7LINE
. . I LA7PAGE,+LA7SMST'=4 W ! D WARN^LA7SMP0
. . S LA7SCOND=$QS(LA7ROOT,3),LA7SCONT=$QS(LA7ROOT,4)
. . S LA7SCOND(0)=$S(LA7SCOND:$$GET1^DIQ(62.93,LA7SCOND_",",.01),1:"None Specified")
. . S LA7SCONT(0)=$S(LA7SCONT:$$GET1^DIQ(62.91,LA7SCONT_",",.01),1:"None Specified")
. . D HED^LA7SMP0 S LA7UID=""
. S LA762801=$QS(LA7ROOT,6)
. 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'=$QS(LA7ROOT,5) D Q:LA7EXIT
. . S LA7UID=$QS(LA7ROOT,5),LA7ITMID=$G(^TMP("LA7ITEM",$J,LA7UID,LA762801))
. . S LRDFN=+LA762801(0) D PTID^LA7SMP0
. . S X=$Q(^LRO(68,"C",LA7UID))
. . I X="" S LA7SKIP=1 Q ; Skip - UID missing.
. . I LA7UID'=$QS(X,3) S LA7SKIP=1 ; Skip - UID missing.
. . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
. . 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)
. . I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),U,2) S LA7CDT=$P(LA7CDT,".")
. . 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,LA7ITEM(LA7SCOND(0))=$G(LA7ITEM(LA7SCOND(0)))+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
. 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:LA7TCOST=""
. . W:$X>(IOM-15) ! W ?(IOM-15)," Cost: $",$FN(LA7TCOST,",",2)
. I LA762801(.1)'="" D
. . N DIWF,DIWL,DIWR,LA7CMT
. . K ^UTILITY($J)
. . 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 !,?13,"VA NLT Code [Name]: "
. S LA7NLT=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",1) ; NLT code.
. W $S(LA7NLT'="":LA7NLT,1:"*** None specified ***")
. S LA7NLTN=""
. I LA7NLT'="" S LA7NLTN=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",.01) ; NLT code test name.
. I LA7NLTN'="" W:($X+$L(LA7NLTN)+3)>IOM !,?32 W " [",LA7NLTN,"]"
. 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($P(LA762801(5),"^")'="":$P(LA762801(5),"^"),1:"*** None specified ***")," "
. . S LA7Y="["_$S($P(LA762801(5),"^",2)'="":$P(LA762801(5),"^",2),1:"*** None specified ***")_"]"
. . I $L(LA7Y)<(IOM-$X) W LA7Y Q
. . S LA7X=IOM-$X W $E(LA7Y,1,LA7X)
. . 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
. S $P(LA7SMR,"^",2)=1 ; Flag that we're now printing receipt
. D HED^LA7SMP0
. W !!,"Shipping condition and specimens shipped"
. S I=0 F S I=$O(LA7ITEM(I)) Q:I="" W !,?2,$$LJ^XLFSTR(I,30,"."),": ",$J(LA7ITEM(I),4,0)," specimens"
. W !,?34,$$REPEAT^XLFSTR("-",14)
. W !,?2,$$LJ^XLFSTR("Total number of specimens",30,"."),": ",$J(LA7ITEM,4,0)
. 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)
. . I $D(LA7ERR(LA7I,.1)) W !,?5,LA7ERR(LA7I,.1)
. . S LA7ROOT="^TMP(""LA7ERR"",$J,LA7I,$P(LA7SM,""^""))"
. . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'="LA7ERR"!($QS(LA7ROOT,2)'=$J)!($QS(LA7ROOT,3)'=LA7I)!($QS(LA7ROOT,4)'=$P(LA7SM,"^")) D Q:LA7EXIT
. . . I ($Y+6)>IOSL D HED^LA7SMP0 Q:LA7EXIT W LA7ERR(LA7I)," (Cont'd)"
. . . W !,?10,"UID: ",$QS(LA7ROOT,5)," Test: ",$$GET1^DIQ(60,$QS(LA7ROOT,6)_",",.01)
. . 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("NVAF")=$$NVAF^LA7VHLU2(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("NVAF")=$$NVAF^LA7VHLU2(LA7Y)
S LA7TS(99)=$$RETFACID^LA7VHLU2(LA7Y,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"
;
S DIR("B")=""
I $G(LA7SM)>0 D
. N LA7629,X
. S LA7629=$P($G(^LAHM(62.8,+LA7SM,0)),"^",2)
. I LA7629<1 Q
. S X=$$GET^XPAR("USR^PKG","LA7S MANIFEST DEFLT PRINT","`"_LA7629,"Q")
. I X'="" S DIR("B")=$S(X=1:"YES",1:"NO")
I DIR("B")="" S DIR("B")="NO"
;
D ^DIR Q:$D(DIRUT)
I Y=1 D DEV,END^LA7SMP0
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMP 10001 printed Dec 13, 2024@01:39:31 Page 2
LA7SMP ;DALOI/JMC - Shipping Manifest Print ;03/26/10 16:26
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,45,46,64,74**;Sep 27, 1994;Build 229
+2 ;
EN ; Entry point to print a shipping manifest
+1 ;
+2 NEW LA7CHK,LA7SCFG,LA7EXIT,LA7PAGE,LA7QUIT,LA7SBC,LA7SM
+3 ;
+4 DO EN^DDIOL("Print Shipping Manifest","","!!")
+5 DO KILL^LA7SMP0
+6 DO INIT^LA7SMP0
+7 IF LA7QUIT
DO KILL^LA7SMP0
QUIT
+8 SET LA7SM=$$SELSM^LA7SMU(+LA7SCFG)
+9 IF LA7SM<0
Begin DoDot:1
+10 DO EN^DDIOL($PIECE(LA7SM,"^",2),"","!?5")
+11 DO KILL^LA7SMP0
End DoDot:1
QUIT
+12 ;
+13 ; flag to check for missing info.
SET LA7CHK=1
+14 WRITE !
+15 DO DEV
+16 DO END^LA7SMP0
+17 QUIT
+18 ;
+19 ;
DEV ; Alternate entry point when user has already selected a manifest.
+1 ;
+2 ;ZEXCEPT: %ZIS,IOM,IOSL,IOST,LA7CHK,LA7EXIT,LA7PAGE,LA7SBC,LA7SCFG,LA7SM,POP,ZTQUEUED
+3 ;
+4 ; Determine if bar codes on manifest
+5 SET LA7SBC=$$GET1^DIQ(62.9,+LA7SCFG_",",.09,"I")
+6 ;
+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 IF LA7SBC
IF $PIECE($GET(^LAHM(62.8,+LA7SM,0)),"^",3)=4
Begin DoDot:1
+10 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+11 SET DIR(0)="YO"
SET DIR("A")="Print barcodes on manifest"
SET DIR("B")="YES"
+12 DO ^DIR
+13 IF $DATA(DIRUT)
SET LA7EXIT=1
+14 IF Y'=1
SET LA7SBC=0
End DoDot:1
+15 IF $GET(LA7EXIT)
QUIT
+16 ;
+17 SET %ZIS="MQ"
DO ^%ZIS
+18 IF POP
Begin DoDot:1
+19 DO HOME^%ZIS
+20 SET LA7EXIT=1
End DoDot:1
QUIT
+21 IF $DATA(IO("Q"))
Begin DoDot:1
+22 NEW ZTDESC,ZTDTH,ZTSK,ZTRTN,ZTIO,ZTSAVE
+23 SET ZTRTN="DQ^LA7SMP"
SET ZTSAVE("LA7*")=""
SET ZTDESC="Lab Shipping Manifest Print"
+24 DO ^%ZTLOAD
DO ^%ZISC
+25 DO EN^DDIOL("Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
+26 SET LA7EXIT=1
End DoDot:1
QUIT
DQ ;
+1 ;
+2 USE IO
+3 ;
+4 NEW I,LA760,LA762,LA762801,LA7AA,LA7ACC,LA7AD,LA7AN,LA7CDT,LA7DC,LA7ERR,LA7EXIT,LA7END,LA7FSITE
+5 NEW LA7I,LA7ITEM,LA7ITMID,LA7LINE,LA7NLT,LA7NLTN,LA7NOW,LA7PROV,LA7QUIT,LA7ROOT
+6 NEW LA7SCFG,LA7SCOND,LA7SCONT,LA7SDT,LA7SKIP,LA7SMR,LA7SMST,LA7SPEC,LA7SVIA,LA7TSITE,LA7UID
+7 NEW LRDFN
+8 ;
+9 SET LA7SM(0)=$GET(^LAHM(62.8,+LA7SM,0))
+10 SET LA7SCFG=+$PIECE(LA7SM(0),"^",2)
SET LA7SCFG(0)=$GET(^LAHM(62.9,LA7SCFG,0))
+11 SET (LA7DC,LA7EXIT,LA7END,LA7ITEM,LA7PAGE,LA7SMR,LA760,LA762801)=0
+12 ;
+13 ; Get collecting site's names and station numbers
+14 DO GETSITE^LA7SMP($PIECE(LA7SCFG(0),"^",2),$PIECE(LA7SCFG(0),"^",3),.LA7FSITE,.LA7TSITE)
+15 ;
+16 ; Flag - skip if accession deleted
+17 SET LA7SKIP=0
+18 ; Check manifest for missing info.
+19 IF $GET(LA7CHK)=""
SET LA7CHK=1
+20 ;
+21 SET LA7NOW=$$HTE^XLFDT($HOROLOG,"1M")
+22 ; Manifest status
+23 SET LA7SMST=$PIECE(LA7SM(0),"^",3)
+24 IF LA7SMST=4
Begin DoDot:1
+25 ; Get shipping date
+26 SET LA7SDT=$$SMED^LA7SMU(LA7SM,"SM05")
+27 ; Flag to print receipt.
+28 IF IOST["P-"
SET LA7SMR=$PIECE(LA7SCFG(0),"^",10)
End DoDot:1
+29 ;
+30 ; Set barcode flag to "off"
+31 IF LA7SBC
IF IOST'["P-"
SET LA7SBC=0
+32 ;
+33 SET $PIECE(LA7SMST,"^",2)=$$EXTERNAL^DILFD(62.8,.03,"",LA7SMST)
+34 SET LA7LINE=""
SET $PIECE(LA7LINE,"-",IOM)=""
+35 SET LA7SVIA=$SELECT($PIECE(LA7SM(0),"^",4):$$GET1^DIQ(62.92,$PIECE(LA7SM(0),"^",4)_",",.01),1:"None Specified")
+36 ;
+37 FOR
SET LA762801=$ORDER(^LAHM(62.8,+LA7SM,10,LA762801))
if 'LA762801
QUIT
Begin DoDot:1
+38 FOR I=0,1,2
SET LA762801(I)=$GET(^LAHM(62.8,+LA7SM,10,LA762801,I))
+39 ; Test previously "removed".
IF $PIECE(LA762801(0),"^",8)=0
QUIT
+40 SET LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
+41 ; Accession/test deleted
IF LA7SKIP
IF LA7SKIP<3
QUIT
+42 IF $GET(LA7CHK)
DO CHKREQI^LA7SM2(+LA7SM,LA762801)
+43 SET ^TMP("LA7SM",$JOB,+$PIECE(LA762801(0),"^",7),+$PIECE(LA762801(0),"^",9),$PIECE(LA762801(0),"^",5),LA762801)=""
+44 DO BUILDRI^LA7SM2
End DoDot:1
+45 ;
+46 ; Setup item identifiers for printed manifest
+47 DO ITEM^LA7SMP0
+48 ;
+49 SET (LA7ITMID,LA7SCOND,LA7SCOND(0),LA7SCONT,LA7SCONT(0),LA7UID)=""
+50 ;
+51 IF '$DATA(^TMP("LA7SM",$JOB))
Begin DoDot:1
+52 DO HED^LA7SMP0
+53 WRITE !!,$$CJ^XLFSTR("No entries to print",IOM)
End DoDot:1
+54 ;
+55 SET LA7ROOT="^TMP(""LA7SM"",$J)"
+56 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'="LA7SM"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
QUIT
Begin DoDot:1
+57 IF LA7EXIT
QUIT
+58 IF LA7UID'=""
IF LA7UID'=$QSUBSCRIPT(LA7ROOT,5)
WRITE !,LA7LINE
+59 IF LA7SCOND'=$QSUBSCRIPT(LA7ROOT,3)!(LA7SCONT'=$QSUBSCRIPT(LA7ROOT,4))
Begin DoDot:2
+60 IF LA7UID'=""
IF LA7UID=$QSUBSCRIPT(LA7ROOT,5)
WRITE !,LA7LINE
+61 IF LA7PAGE
IF +LA7SMST'=4
WRITE !
DO WARN^LA7SMP0
+62 SET LA7SCOND=$QSUBSCRIPT(LA7ROOT,3)
SET LA7SCONT=$QSUBSCRIPT(LA7ROOT,4)
+63 SET LA7SCOND(0)=$SELECT(LA7SCOND:$$GET1^DIQ(62.93,LA7SCOND_",",.01),1:"None Specified")
+64 SET LA7SCONT(0)=$SELECT(LA7SCONT:$$GET1^DIQ(62.91,LA7SCONT_",",.01),1:"None Specified")
+65 DO HED^LA7SMP0
SET LA7UID=""
End DoDot:2
if LA7EXIT
QUIT
+66 SET LA762801=$QSUBSCRIPT(LA7ROOT,6)
+67 FOR I=0,.1,2,5
SET LA762801(I)=$GET(^LAHM(62.8,+LA7SM,10,LA762801,I))
+68 ; File #60 test ien
SET LA760=+$PIECE(LA762801(0),"^",2)
+69 IF LA7UID'=$QSUBSCRIPT(LA7ROOT,5)
Begin DoDot:2
+70 SET LA7UID=$QSUBSCRIPT(LA7ROOT,5)
SET LA7ITMID=$GET(^TMP("LA7ITEM",$JOB,LA7UID,LA762801))
+71 SET LRDFN=+LA762801(0)
DO PTID^LA7SMP0
+72 SET X=$QUERY(^LRO(68,"C",LA7UID))
+73 ; Skip - UID missing.
IF X=""
SET LA7SKIP=1
QUIT
+74 ; Skip - UID missing.
IF LA7UID'=$QSUBSCRIPT(X,3)
SET LA7SKIP=1
+75 SET LA7AA=+$QSUBSCRIPT(X,4)
SET LA7AD=+$QSUBSCRIPT(X,5)
SET LA7AN=+$QSUBSCRIPT(X,6)
+76 SET LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
+77 ; Skip - accession/test deleted.
IF LA7SKIP
IF LA7SKIP<3
QUIT
+78 SET LA7ACC=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.2),"Accession not available"),"^")
+79 SET X=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0),"Not available"),U,8)
+80 SET LA7PROV=$SELECT(X>0:X,1:"")_"^"_$SELECT(X>0:$$PRAC^LRX(X),1:X)
+81 SET LA7CDT=$PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3),"Not available"),U,1)
+82 IF $PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),U,2)
SET LA7CDT=$PIECE(LA7CDT,".")
+83 SET LA7SPEC=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,1,0),"Not available")
+84 IF LA7SPEC
SET LA7SPEC(0)=$GET(^LAB(61,+LA7SPEC,0))
+85 IF '$TEST
SET LA7SPEC(0)="Specimen info not assigned"
+86 SET LA762=$PIECE(LA7SPEC,"^",2)
+87 IF LA762
SET LA762(0)=$GET(^LAB(62,LA762,0))
+88 IF '$TEST
SET LA762(0)="Collection info not assigned"
+89 SET LA7ITEM=LA7ITEM+1
SET LA7ITEM(LA7SCOND(0))=$GET(LA7ITEM(LA7SCOND(0)))+1
+90 IF ($Y+12)>IOSL
Begin DoDot:3
+91 WRITE !
+92 IF +LA7SMST'=4
DO WARN^LA7SMP0
+93 DO HED^LA7SMP0
End DoDot:3
if LA7EXIT
QUIT
+94 DO SH^LA7SMP0
End DoDot:2
if LA7EXIT
QUIT
+95 ; Skip - accession/test deleted.
IF LA7SKIP
IF LA7SKIP<3
QUIT
+96 IF ($Y+6)>IOSL
Begin DoDot:2
+97 WRITE !,LA7LINE
+98 IF +LA7SMST'=4
WRITE !
DO WARN^LA7SMP0
+99 DO HED^LA7SMP0
if LA7EXIT
QUIT
+100 SET LA7DC=1
DO SH^LA7SMP0
End DoDot:2
if LA7EXIT
QUIT
+101 WRITE !,?11,$EXTRACT(LA7LINE,1,41)
+102 WRITE !,?11,$PIECE(^LAB(60,LA760,0),"^",1),?43,$PIECE(LA7SPEC(0),"^")
+103 IF +LA7SMST'=4
Begin DoDot:2
+104 NEW LA7TCOST
+105 SET LA7TCOST=$$GET1^DIQ(60,LA760_",",1,"E")
if LA7TCOST=""
QUIT
+106 if $X>(IOM-15)
WRITE !
WRITE ?(IOM-15)," Cost: $",$FNUMBER(LA7TCOST,",",2)
End DoDot:2
+107 IF LA762801(.1)'=""
Begin DoDot:2
+108 NEW DIWF,DIWL,DIWR,LA7CMT
+109 KILL ^UTILITY($JOB)
+110 SET DIWL=1
SET DIWR=IOM-13
SET DIWF=""
+111 SET X="Relevant clinical information: "_LA762801(.1)
DO ^DIWP
+112 MERGE LA7CMT=^UTILITY($JOB,"W",DIWL)
+113 WRITE !
DO CMT^LA7SMP0
WRITE !
End DoDot:2
+114 WRITE !,?13,"VA NLT Code [Name]: "
+115 ; NLT code.
SET LA7NLT=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",1)
+116 WRITE $SELECT(LA7NLT'="":LA7NLT,1:"*** None specified ***")
+117 SET LA7NLTN=""
+118 ; NLT code test name.
IF LA7NLT'=""
SET LA7NLTN=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",.01)
+119 IF LA7NLTN'=""
if ($X+$LENGTH(LA7NLTN)+3)>IOM
WRITE !,?32
WRITE " [",LA7NLTN,"]"
+120 ; Print non-VA test code info
IF $PIECE(LA7SM(0),"^",5)
Begin DoDot:2
+121 NEW LA7X,LA7Y,LA7Z
+122 SET LA7X=$PIECE($GET(^DIC(4,+$PIECE(LA7SCFG(0),"^",3),0),"UNKNOWN"),"^",1)_" Order Code [Name]: "
+123 WRITE !,?11,LA7X,$SELECT($PIECE(LA762801(5),"^")'="":$PIECE(LA762801(5),"^"),1:"*** None specified ***")," "
+124 SET LA7Y="["_$SELECT($PIECE(LA762801(5),"^",2)'="":$PIECE(LA762801(5),"^",2),1:"*** None specified ***")_"]"
+125 IF $LENGTH(LA7Y)<(IOM-$X)
WRITE LA7Y
QUIT
+126 SET LA7X=IOM-$X
WRITE $EXTRACT(LA7Y,1,LA7X)
+127 SET LA7Y=$EXTRACT(LA7Y,LA7X+1,$LENGTH(LA7Y))
SET LA7Z=IOM-11
+128 FOR
SET LA7X=$EXTRACT(LA7Y,1,LA7Z)
if LA7X=""
QUIT
WRITE !,?11,LA7X
SET LA7Y=$EXTRACT(LA7Y,LA7Z+1,$LENGTH(LA7Y))
End DoDot:2
End DoDot:1
if LA7EXIT
QUIT
+129 ;
+130 IF LA7EXIT
QUIT
+131 ;
+132 WRITE !,LA7LINE,!!,"End of Shipping Manifest"
+133 ;
+134 IF +LA7SMST'=4
Begin DoDot:1
+135 IF IOM<131
WRITE !
+136 DO WARN^LA7SMP0
End DoDot:1
+137 ;
+138 ; Print shipping manifest receipt.
+139 IF LA7SMR
Begin DoDot:1
+140 ; Flag that we're now printing receipt
SET $PIECE(LA7SMR,"^",2)=1
+141 DO HED^LA7SMP0
+142 WRITE !!,"Shipping condition and specimens shipped"
+143 SET I=0
FOR
SET I=$ORDER(LA7ITEM(I))
if I=""
QUIT
WRITE !,?2,$$LJ^XLFSTR(I,30,"."),": ",$JUSTIFY(LA7ITEM(I),4,0)," specimens"
+144 WRITE !,?34,$$REPEAT^XLFSTR("-",14)
+145 WRITE !,?2,$$LJ^XLFSTR("Total number of specimens",30,"."),": ",$JUSTIFY(LA7ITEM,4,0)
+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 IF $DATA(LA7ERR(LA7I,.1))
WRITE !,?5,LA7ERR(LA7I,.1)
+158 SET LA7ROOT="^TMP(""LA7ERR"",$J,LA7I,$P(LA7SM,""^""))"
+159 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'="LA7ERR"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)!($QSUBSCRIPT(LA7ROOT,3)'=LA7I)!($QSUBSCRIPT(LA7ROOT,4)'=$PIECE(LA7SM,"^"))
QUIT
Begin DoDot:3
+160 IF ($Y+6)>IOSL
DO HED^LA7SMP0
if LA7EXIT
QUIT
WRITE LA7ERR(LA7I)," (Cont'd)"
+161 WRITE !,?10,"UID: ",$QSUBSCRIPT(LA7ROOT,5)," Test: ",$$GET1^DIQ(60,$QSUBSCRIPT(LA7ROOT,6)_",",.01)
End DoDot:3
if LA7EXIT
QUIT
+162 WRITE !!
End DoDot:2
if LA7EXIT
QUIT
End DoDot:1
+163 ;
+164 IF $DATA(ZTQUEUED)
DO END^LA7SMP0
+165 ;
+166 QUIT
+167 ;
+168 ;
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("NVAF")=$$NVAF^LA7VHLU2(LA7X)
+11 SET LA7FS(99)=$$RETFACID^LA7VHLU2(LA7X,2,1)
+12 IF LA7FS(99)=""
SET LA7FS(99)="UNK: #"_+LA7X
+13 ;
+14 ; Get host site's names and station numbers
+15 SET LA7TS=$$GET1^DIQ(4,LA7Y_",",.01)
+16 IF LA7TS=""
SET LA7TS="UNKNOWN:Entry #"_+LA7Y
+17 SET LA7TS("NVAF")=$$NVAF^LA7VHLU2(LA7Y)
+18 SET LA7TS(99)=$$RETFACID^LA7VHLU2(LA7Y,1,1)
+19 IF LA7TS(99)=""
SET LA7TS(99)="UNK: #"_+LA7Y
+20 QUIT
+21 ;
+22 ;
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"
+6 ;
+7 SET DIR("B")=""
+8 IF $GET(LA7SM)>0
Begin DoDot:1
+9 NEW LA7629,X
+10 SET LA7629=$PIECE($GET(^LAHM(62.8,+LA7SM,0)),"^",2)
+11 IF LA7629<1
QUIT
+12 SET X=$$GET^XPAR("USR^PKG","LA7S MANIFEST DEFLT PRINT","`"_LA7629,"Q")
+13 IF X'=""
SET DIR("B")=$SELECT(X=1:"YES",1:"NO")
End DoDot:1
+14 IF DIR("B")=""
SET DIR("B")="NO"
+15 ;
+16 DO ^DIR
if $DATA(DIRUT)
QUIT
+17 IF Y=1
DO DEV
DO END^LA7SMP0
+18 ;
+19 QUIT
