LA7SMPXL ;DALOI/JMC - PRINT SHIPPING MANIFEST FROM PENDING ORDERS FILE ;12/02/09 13:35
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46,64,74**;Sep 27, 1994;Build 229
;
;
EN ; Entry point from menu option
;
N D,DIC,LA7SM,X,Y,%ZIS
;
S DIC=69.6,DIC(0)="AQEZNM",DIC("A")="Select Shipping Manifest: ",D="D^E^AE"
S DIC("S")="I $P(^(0),U,14)'="""""
D MIX^DIC1 K DIC("S")
I Y<1 D END Q
;
S LA7SMAN=$P(Y(0),U,14)
;
S %ZIS="MQ"
D ^%ZIS
I POP D Q
. D HOME^%ZIS
. D END
;
I $D(IO("Q")) D Q
. S ZTRTN="DQ^LA7SMPXL",ZTDESC="Shipping Manifest Reprint",ZTSAVE("LA7*")=""
. D ^%ZTLOAD,HOME^%ZIS
. D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
. D END
;
DQ ; Tasked entry point
;
U IO
;
S DT=$$DT^XLFDT
S LRDPF=69.6,LA7NOW=$$HTE^XLFDT($H,"1M")
S (LA7DC,LA7EXIT,LA7PAGE,LA7SCOND,LA7SCONT)=0
S LA7SCFG=0,$P(LA7SCFG(0),"^",7)="-1"
S LA7LINE="",$P(LA7LINE,"-",IOM)="",LA7SVIA="Electronic manifest"
;
; Check manifest for missing info.
S LA7CHK=0
; Flag to print receipt.
S LA7SMR="0^0"
; Set barcode flag
S LA7SBC=0
I IOST["P-" S LA7SBC=2
; Shipping status flag
S LA7SMST="0^Electronic Manifest"
;
S (LA7696,LA7QUIT)=0,LA7UID=""
S LA7SM="^"_LA7SMAN
S LA7ROOT="^LRO(69.6,""AD"",LA7SMAN)"
F LA7ITEM=1:1 S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7EXIT
. I $QS(LA7ROOT,3)'=LA7SMAN S LA7EXIT=1 Q
. S LA7UID=$QS(LA7ROOT,4),LA7696=$QS(LA7ROOT,5),LA76964=0
. F S LA76964=$O(^LRO(69.6,LA7696,2,LA76964)) Q:LA76964<1 D
. . S LA7ITMID=$P($G(^LRO(69.6,LA7696,2,LA76964,700.19)),"^",8)
. . I LA7ITMID="" S LA7ITMID=LA7ITEM
. . S ^TMP("LA7SM",$J,LA7ITMID,0,LA7UID,LA7696)=""
;
S LA7ROOT="^TMP(""LA7SM"",$J)",LA7EXIT=0,LA7UID=""
F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'="LA7SM"!($QS(LA7ROOT,2)'=$J) D Q:LA7EXIT
. I LA7UID'="",LA7UID'=$QS(LA7ROOT,5) W !,LA7LINE
. S LA7ITMID=$QS(LA7ROOT,3),LA7696=$QS(LA7ROOT,6)
. D SETUP
. I ($Y+12)>IOSL!('LA7PAGE) D Q:LA7EXIT
. . I LA7PAGE W ! D WARN^LA7SMP0
. . D HED^LA7SMP0
. D SH^LA7SMP0
. I $D(LA7CMT) D CMT^LA7SMP0
. W !,?18,$E(LA7LINE,1,31)
. S LA76964=0
. F S LA76964=$O(^LRO(69.6,LA7696,2,LA76964)) Q:LA76964<1 D
. . S X=$P($G(^LRO(69.6,LA7696,2,LA76964,700.19)),"^",8)
. . I X'="",X'=LA7ITMID Q
. . S LA76964(0)=$G(^LRO(69.6,LA7696,2,LA76964,0))
. . W !?18,$P(LA76964(0),"^",3),?50,$P(LA7SPEC(0),"^")
. . W !,?20,"VA NLT code [Name]: "
. . S LA7NLT=$P(LA76964(0),"^",2)
. . W $S(LA7NLT'="":LA7NLT,1:"*** None specified ***")
. . S LA7NLTN=$P(LA76964(0),"^")
. . I LA7NLTN'="" W:($X+$L($P(LA76964(0),"^",2))+3)>IOM !,?39 W " [",LA7NLTN,"]"
. . I $P(LA76964(0),"^",9)'="" W !,?20,"Host site UID: ",$P(LA76964(0),"^",9)
;
D END
Q
;
;
SETUP ; Setup variables for this order
;
N I,X
;
F I=0,1 S LA7696(I)=$G(^LRO(69.6,LA7696,I))
;
S PNM=$P(LA7696(0),U),SEX=$P(LA7696(0),U,2),DOB=$P(LA7696(0),U,3),LA7ICN=""
S (SSN,SSN(2))=$P(LA7696(0),U,9)
;
S LA7ACC=$P(LA7696(0),"^",12)
S LA7UID=$P(LA7696(0),"^",6)
S LA7SPEC=+$P(LA7696(0),"^",7),LA7SPEC(0)=$G(^LAB(61,LA7SPEC,0))
S LA7CDT=$P(LA7696(1),U,2)
S LA7SDT=$P(LA7696(1),U,5)
S LA7SCOND(0)="None Specified"
S LA7SCONT(0)="None Specified"
;
; Get collecting site and host site info
D GETSITE^LA7SMP($P(LA7696(0),U,5),DUZ(2),.LA7FSITE,.LA7TSITE)
;
; Ordering provider
S I=0,LA7PROV=""
F S I=$O(^LRO(69.6,LA7696,2,I)) Q:'I D Q:LA7PROV'=""
. S X=$P($G(^LRO(69.6,LA7696,2,I,1)),"^")
. I X'="" S $P(LA7PROV,"^",2)=$P(X,"[")
I LA7PROV="" S LA7PROV="^REF:"_LA7FSITE(99)
;
; Get shipping date
S LA7SDT=$$FMTE^XLFDT($P(LA7696(1),"^",3),"")
;
; Check for comments
K LA7CMT
I $D(^LRO(69.6,LA7696,99,0)) D
. N DIWF,DIWL,DIWR,LA7ERR,X
. S LA7CMT=$$GET1^DIQ(69.6,LA7696_",",99,"","LA7CMT","LA7ERR(2)")
. K ^UTILITY($J,"W")
. S DIWL=1,DIWR=IOM-13,DIWF=""
. I $$GET1^DID(+$$GET1^DID(69.6,99,"","SPECIFIER","LA7ERR(1)"),.01,"","SPECIFIER","LA7ERR(3)")["L" S DIWF="N"
. S LA7I=$O(LA7CMT(0)),LA7CMT(LA7I)="COMMENTS: "_LA7CMT(LA7I),LA7I=0
. F S LA7I=$O(LA7CMT(LA7I)) Q:'LA7I S X=LA7CMT(LA7I) D ^DIWP
. K LA7CMT
. M LA7CMT=^UTILITY($J,"W",DIWL)
. K ^UTILITY($J,"W")
;
; Add local (host) status info
S LA7CMT=$G(LA7CMT)+1
I LA7CMT>1 S LA7CMT(LA7CMT,0)=" ",LA7CMT=LA7CMT+1
S LA7CMT(LA7CMT,0)="Host test status: "_$$GET1^DIQ(69.6,LA7696_",",6,"",,"LA7ERR(4)")
Q
;
;
END ;
S LA7EXIT=1
D END^LA7SMP0
K LA7696,LA76964,LA7CMT,LA7ITEM,LA7ITMID,LA7SMAN
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMPXL 4518 printed Apr 09, 2024@20:47:18 Page 2
LA7SMPXL ;DALOI/JMC - PRINT SHIPPING MANIFEST FROM PENDING ORDERS FILE ;12/02/09 13:35
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46,64,74**;Sep 27, 1994;Build 229
+2 ;
+3 ;
EN ; Entry point from menu option
+1 ;
+2 NEW D,DIC,LA7SM,X,Y,%ZIS
+3 ;
+4 SET DIC=69.6
SET DIC(0)="AQEZNM"
SET DIC("A")="Select Shipping Manifest: "
SET D="D^E^AE"
+5 SET DIC("S")="I $P(^(0),U,14)'="""""
+6 DO MIX^DIC1
KILL DIC("S")
+7 IF Y<1
DO END
QUIT
+8 ;
+9 SET LA7SMAN=$PIECE(Y(0),U,14)
+10 ;
+11 SET %ZIS="MQ"
+12 DO ^%ZIS
+13 IF POP
Begin DoDot:1
+14 DO HOME^%ZIS
+15 DO END
End DoDot:1
QUIT
+16 ;
+17 IF $DATA(IO("Q"))
Begin DoDot:1
+18 SET ZTRTN="DQ^LA7SMPXL"
SET ZTDESC="Shipping Manifest Reprint"
SET ZTSAVE("LA7*")=""
+19 DO ^%ZTLOAD
DO HOME^%ZIS
+20 DO EN^DDIOL("Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
+21 DO END
End DoDot:1
QUIT
+22 ;
DQ ; Tasked entry point
+1 ;
+2 USE IO
+3 ;
+4 SET DT=$$DT^XLFDT
+5 SET LRDPF=69.6
SET LA7NOW=$$HTE^XLFDT($HOROLOG,"1M")
+6 SET (LA7DC,LA7EXIT,LA7PAGE,LA7SCOND,LA7SCONT)=0
+7 SET LA7SCFG=0
SET $PIECE(LA7SCFG(0),"^",7)="-1"
+8 SET LA7LINE=""
SET $PIECE(LA7LINE,"-",IOM)=""
SET LA7SVIA="Electronic manifest"
+9 ;
+10 ; Check manifest for missing info.
+11 SET LA7CHK=0
+12 ; Flag to print receipt.
+13 SET LA7SMR="0^0"
+14 ; Set barcode flag
+15 SET LA7SBC=0
+16 IF IOST["P-"
SET LA7SBC=2
+17 ; Shipping status flag
+18 SET LA7SMST="0^Electronic Manifest"
+19 ;
+20 SET (LA7696,LA7QUIT)=0
SET LA7UID=""
+21 SET LA7SM="^"_LA7SMAN
+22 SET LA7ROOT="^LRO(69.6,""AD"",LA7SMAN)"
+23 FOR LA7ITEM=1:1
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
Begin DoDot:1
+24 IF $QSUBSCRIPT(LA7ROOT,3)'=LA7SMAN
SET LA7EXIT=1
QUIT
+25 SET LA7UID=$QSUBSCRIPT(LA7ROOT,4)
SET LA7696=$QSUBSCRIPT(LA7ROOT,5)
SET LA76964=0
+26 FOR
SET LA76964=$ORDER(^LRO(69.6,LA7696,2,LA76964))
if LA76964<1
QUIT
Begin DoDot:2
+27 SET LA7ITMID=$PIECE($GET(^LRO(69.6,LA7696,2,LA76964,700.19)),"^",8)
+28 IF LA7ITMID=""
SET LA7ITMID=LA7ITEM
+29 SET ^TMP("LA7SM",$JOB,LA7ITMID,0,LA7UID,LA7696)=""
End DoDot:2
End DoDot:1
if LA7EXIT
QUIT
+30 ;
+31 SET LA7ROOT="^TMP(""LA7SM"",$J)"
SET LA7EXIT=0
SET LA7UID=""
+32 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'="LA7SM"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
QUIT
Begin DoDot:1
+33 IF LA7UID'=""
IF LA7UID'=$QSUBSCRIPT(LA7ROOT,5)
WRITE !,LA7LINE
+34 SET LA7ITMID=$QSUBSCRIPT(LA7ROOT,3)
SET LA7696=$QSUBSCRIPT(LA7ROOT,6)
+35 DO SETUP
+36 IF ($Y+12)>IOSL!('LA7PAGE)
Begin DoDot:2
+37 IF LA7PAGE
WRITE !
DO WARN^LA7SMP0
+38 DO HED^LA7SMP0
End DoDot:2
if LA7EXIT
QUIT
+39 DO SH^LA7SMP0
+40 IF $DATA(LA7CMT)
DO CMT^LA7SMP0
+41 WRITE !,?18,$EXTRACT(LA7LINE,1,31)
+42 SET LA76964=0
+43 FOR
SET LA76964=$ORDER(^LRO(69.6,LA7696,2,LA76964))
if LA76964<1
QUIT
Begin DoDot:2
+44 SET X=$PIECE($GET(^LRO(69.6,LA7696,2,LA76964,700.19)),"^",8)
+45 IF X'=""
IF X'=LA7ITMID
QUIT
+46 SET LA76964(0)=$GET(^LRO(69.6,LA7696,2,LA76964,0))
+47 WRITE !?18,$PIECE(LA76964(0),"^",3),?50,$PIECE(LA7SPEC(0),"^")
+48 WRITE !,?20,"VA NLT code [Name]: "
+49 SET LA7NLT=$PIECE(LA76964(0),"^",2)
+50 WRITE $SELECT(LA7NLT'="":LA7NLT,1:"*** None specified ***")
+51 SET LA7NLTN=$PIECE(LA76964(0),"^")
+52 IF LA7NLTN'=""
if ($X+$LENGTH($PIECE(LA76964(0),"^",2))+3)>IOM
WRITE !,?39
WRITE " [",LA7NLTN,"]"
+53 IF $PIECE(LA76964(0),"^",9)'=""
WRITE !,?20,"Host site UID: ",$PIECE(LA76964(0),"^",9)
End DoDot:2
End DoDot:1
if LA7EXIT
QUIT
+54 ;
+55 DO END
+56 QUIT
+57 ;
+58 ;
SETUP ; Setup variables for this order
+1 ;
+2 NEW I,X
+3 ;
+4 FOR I=0,1
SET LA7696(I)=$GET(^LRO(69.6,LA7696,I))
+5 ;
+6 SET PNM=$PIECE(LA7696(0),U)
SET SEX=$PIECE(LA7696(0),U,2)
SET DOB=$PIECE(LA7696(0),U,3)
SET LA7ICN=""
+7 SET (SSN,SSN(2))=$PIECE(LA7696(0),U,9)
+8 ;
+9 SET LA7ACC=$PIECE(LA7696(0),"^",12)
+10 SET LA7UID=$PIECE(LA7696(0),"^",6)
+11 SET LA7SPEC=+$PIECE(LA7696(0),"^",7)
SET LA7SPEC(0)=$GET(^LAB(61,LA7SPEC,0))
+12 SET LA7CDT=$PIECE(LA7696(1),U,2)
+13 SET LA7SDT=$PIECE(LA7696(1),U,5)
+14 SET LA7SCOND(0)="None Specified"
+15 SET LA7SCONT(0)="None Specified"
+16 ;
+17 ; Get collecting site and host site info
+18 DO GETSITE^LA7SMP($PIECE(LA7696(0),U,5),DUZ(2),.LA7FSITE,.LA7TSITE)
+19 ;
+20 ; Ordering provider
+21 SET I=0
SET LA7PROV=""
+22 FOR
SET I=$ORDER(^LRO(69.6,LA7696,2,I))
if 'I
QUIT
Begin DoDot:1
+23 SET X=$PIECE($GET(^LRO(69.6,LA7696,2,I,1)),"^")
+24 IF X'=""
SET $PIECE(LA7PROV,"^",2)=$PIECE(X,"[")
End DoDot:1
if LA7PROV'=""
QUIT
+25 IF LA7PROV=""
SET LA7PROV="^REF:"_LA7FSITE(99)
+26 ;
+27 ; Get shipping date
+28 SET LA7SDT=$$FMTE^XLFDT($PIECE(LA7696(1),"^",3),"")
+29 ;
+30 ; Check for comments
+31 KILL LA7CMT
+32 IF $DATA(^LRO(69.6,LA7696,99,0))
Begin DoDot:1
+33 NEW DIWF,DIWL,DIWR,LA7ERR,X
+34 SET LA7CMT=$$GET1^DIQ(69.6,LA7696_",",99,"","LA7CMT","LA7ERR(2)")
+35 KILL ^UTILITY($JOB,"W")
+36 SET DIWL=1
SET DIWR=IOM-13
SET DIWF=""
+37 IF $$GET1^DID(+$$GET1^DID(69.6,99,"","SPECIFIER","LA7ERR(1)"),.01,"","SPECIFIER","LA7ERR(3)")["L"
SET DIWF="N"
+38 SET LA7I=$ORDER(LA7CMT(0))
SET LA7CMT(LA7I)="COMMENTS: "_LA7CMT(LA7I)
SET LA7I=0
+39 FOR
SET LA7I=$ORDER(LA7CMT(LA7I))
if 'LA7I
QUIT
SET X=LA7CMT(LA7I)
DO ^DIWP
+40 KILL LA7CMT
+41 MERGE LA7CMT=^UTILITY($JOB,"W",DIWL)
+42 KILL ^UTILITY($JOB,"W")
End DoDot:1
+43 ;
+44 ; Add local (host) status info
+45 SET LA7CMT=$GET(LA7CMT)+1
+46 IF LA7CMT>1
SET LA7CMT(LA7CMT,0)=" "
SET LA7CMT=LA7CMT+1
+47 SET LA7CMT(LA7CMT,0)="Host test status: "_$$GET1^DIQ(69.6,LA7696_",",6,"",,"LA7ERR(4)")
+48 QUIT
+49 ;
+50 ;
END ;
+1 SET LA7EXIT=1
+2 DO END^LA7SMP0
+3 KILL LA7696,LA76964,LA7CMT,LA7ITEM,LA7ITMID,LA7SMAN
+4 ;
+5 QUIT
