LA7SMU1 ;VA/DALOI/JMC - Shipping Manifest Utility (Cont'd);JUL 06, 2010 3:14 PM
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,65,64,1027**;NOV 01, 1997
;
Q
;
SMW(LA7SM) ; "Write" additional information on DIC lookup of #62.48.
; Called by DIC("W")
; Call with LA7SM = ien of entry in file #62.8
;
N LA7X,LA7Y,LA7EVC
;
S LA7SM(0)=$G(^LAHM(62.8,LA7SM,0))
; Shipping configuration
S LA7X=" "_$P($G(^LAHM(62.9,$P(LA7SM(0),"^",2),0)),"^")
S LA7X=LA7X_" Status: "_$$EXTERNAL^DILFD(62.8,.03,"",$P(LA7SM(0),"^",3))
S LA7EVC="SM"_$S($P(LA7SM(0),"^",3)=0:"00",1:$P("02^03^04^05^07","^",+$P(LA7SM(0),"^",3)))
S LA7Y=$$SMED^LA7SMU(LA7SM,LA7EVC)
S LA7X=LA7X_" as of "_$P(LA7Y,"^",2)
D EN^DDIOL(LA7X,"","?18")
Q
;
;
ADATE ; Select accession dates if specified
;
N DIR,DIRUT,DTOUT,LRAA,X,Y
;
S DIR(0)="YO",DIR("A")="Use default accession dates",DIR("B")="YES"
S DIR("?",1)="Enter ""YES"" to use the current accession date for each accession area utilized by this shipping configuration."
S DIR("?",2)=" "
S DIR("?")="If you select ""NO"" then you will be asked to specify a specific accession date and starting and ending accession numbers for each accession area."
D ^DIR
; User aborted
I $D(DIRUT) S LA7QUIT=1 Q
; Use default accession dates
I Y=1 Q
;
S X=0
F S X=$O(^LAHM(62.9,+LA7SCFG,60,X)) Q:'X D
. S X(0)=$G(^LAHM(62.9,+LA7SCFG,60,X,0))
. I $P(X(0),"^",2),'$D(LA7AA($P(X(0),"^",2))) S LA7AA($P(X(0),"^",2))=""
;
S LA7AA=0
F S LA7AA=$O(LA7AA(LA7AA)) Q:'LA7AA D Q:LA7QUIT
. N %DT,DTOUT,LRAA,LRAD,LREND,LRFAN,LRLAN
. D EN^DDIOL("For Accession Area: "_$P($G(^LRO(68,LA7AA,0)),"^"),"","!!?2")
. S LRAA=LA7AA D ADATE^LRWU3
. I Y<1!($G(DTOUT)) S LA7QUIT=1 Q
. S LA7AA(LA7AA)=$G(LRAD)
. D LRAN^LRWU3
. I LREND S LA7QUIT=1 Q
. S LA7AA(LA7AA)=$G(LRAD)_"^"_$G(LRFAN)_"^"_$G(LRLAN)
Q
;
;
ASKPREV() ; Ask if build should exclude tests from building that have previously
; been removed from a manifest. Allows user to control if tests rebuild
; onto the same or different manifest.
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S DIR(0)="YO"
S DIR("A")="Exclude previously removed tests from building"
S DIR("B")="YES"
S DIR("?",1)="Answer 'YES' if you do NOT want tests previously removed"
S DIR("?",2)="from a manifest to be added to this manifest."
S DIR("?",3)=" "
S DIR("?",4)="Answer 'NO' if you WANT tests to be added to this manifest"
S DIR("?",5)="that were previously removed from a manifest and are"
S DIR("?")="otherwise eligible to be added."
D ^DIR
Q $S($D(DIRUT):-1,1:+Y)
;
;
PREV(LA7UID,LA760) ; Determine if test previously removed from a manifest.
; Checks all manifests for accession/test combination.
; Call with LA7UID = accession's uid
; LA760 = file #60 test ien
;
; Returns 0 = not previously removed from a manifest
; 1 = previously removed from a manifest
;
; Called by LA7SMB
;
N LA7628,LA762801,LA7FLAG,LA7ROOT,LA7X
;
S LA7FLAG=0
I '$L($G(LA7UID))!'(+$G(LA760)) Q LA7FLAG
S LA7ROOT="^LAHM(62.8,""UID"",LA7UID)"
F S LA7ROOT=$Q(@LA7ROOT) Q:$QS(LA7ROOT,3)'=LA7UID D Q:LA7FLAG
. ; Manifest and specimen ien
. S LA7628=$QS(LA7ROOT,4),LA762801=$QS(LA7ROOT,5)
. S LA7X=$G(^LAHM(62.8,LA7628,10,LA762801,0))
. ; Found previous test removal
. I $P(LA7X,"^",2)=LA760,$P(LA7X,"^",8)=0 S LA7FLAG=1
Q LA7FLAG
;
;
DOT(LA7CODE,LA7NCS,LA7UID,LA7628) ; Determine ordered tests
;
; Call with LA7CODE = Test code to look up
; LA7NCS = name of coding system
; LA7UID = accession's UID
; LA7628 = ien of shipping manifest in #62.8
;
; Returns LA760 = ien of test entry in file #60 if found
;
; Given a test code, accession and a shipping manifest finds the
; file #60 test which is associated with the test code on the manifest.
;
; Called from LA7VIN4 to determine ordered test and update shipping event.
N LA760,LA764,LA7I,LA7X,LA7Y
;
S (LA760,LA764)=0
; Quit if no code, UID or configuration passed.
I $G(LA7CODE)=""!($G(LA7UID)="")!($G(LA7628)="") Q LA760
;
; Using NLT codes
I $G(LA7NCS)="99VA64" S LA764=+$O(^LAM("E",LA7CODE,0))
;
; Try NLT in case other system is returning NLT codes but not saying so
I 'LA764,$D(^LAM("E",LA7CODE)) S LA764=+$O(^LAM("E",LA7CODE,0))
;
S LA7I=0
F S LA7I=$O(^LAHM(62.8,LA7628,10,"UID",LA7UID,LA7I)) Q:'LA7I D Q:LA760
. S LA7X=$G(^LAHM(62.8,LA7628,10,LA7I,0))
. S LA7Y=$P(LA7X,"^",2)
. ; Found match on NLT code
. I LA7Y,+$P(^LAB(60,LA7Y,64),"^")=LA764 S LA760=LA7Y Q
. ; Found match on non-VA code
. I LA7CODE=$P($G(^LAHM(62.8,LA7628,10,LA7I,5)),"^") S LA760=LA7Y
;
Q LA760
LA7SMU1 ;VA/DALOI/JMC - Shipping Manifest Utility (Cont'd);JUL 06, 2010 3:14 PM
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,65,64,1027**;NOV 01, 1997
+2 ;
+3 QUIT
+4 ;
SMW(LA7SM) ; "Write" additional information on DIC lookup of #62.48.
+1 ; Called by DIC("W")
+2 ; Call with LA7SM = ien of entry in file #62.8
+3 ;
+4 NEW LA7X,LA7Y,LA7EVC
+5 ;
+6 SET LA7SM(0)=$GET(^LAHM(62.8,LA7SM,0))
+7 ; Shipping configuration
+8 SET LA7X=" "_$PIECE($GET(^LAHM(62.9,$PIECE(LA7SM(0),"^",2),0)),"^")
+9 SET LA7X=LA7X_" Status: "_$$EXTERNAL^DILFD(62.8,.03,"",$PIECE(LA7SM(0),"^",3))
+10 SET LA7EVC="SM"_$SELECT($PIECE(LA7SM(0),"^",3)=0:"00",1:$PIECE("02^03^04^05^07","^",+$PIECE(LA7SM(0),"^",3)))
+11 SET LA7Y=$$SMED^LA7SMU(LA7SM,LA7EVC)
+12 SET LA7X=LA7X_" as of "_$PIECE(LA7Y,"^",2)
+13 DO EN^DDIOL(LA7X,"","?18")
+14 QUIT
+15 ;
+16 ;
ADATE ; Select accession dates if specified
+1 ;
+2 NEW DIR,DIRUT,DTOUT,LRAA,X,Y
+3 ;
+4 SET DIR(0)="YO"
SET DIR("A")="Use default accession dates"
SET DIR("B")="YES"
+5 SET DIR("?",1)="Enter ""YES"" to use the current accession date for each accession area utilized by this shipping configuration."
+6 SET DIR("?",2)=" "
+7 SET DIR("?")="If you select ""NO"" then you will be asked to specify a specific accession date and starting and ending accession numbers for each accession area."
+8 DO ^DIR
+9 ; User aborted
+10 IF $DATA(DIRUT)
SET LA7QUIT=1
QUIT
+11 ; Use default accession dates
+12 IF Y=1
QUIT
+13 ;
+14 SET X=0
+15 FOR
SET X=$ORDER(^LAHM(62.9,+LA7SCFG,60,X))
IF 'X
QUIT
Begin DoDot:1
+16 SET X(0)=$GET(^LAHM(62.9,+LA7SCFG,60,X,0))
+17 IF $PIECE(X(0),"^",2)
IF '$DATA(LA7AA($PIECE(X(0),"^",2)))
SET LA7AA($PIECE(X(0),"^",2))=""
End DoDot:1
+18 ;
+19 SET LA7AA=0
+20 FOR
SET LA7AA=$ORDER(LA7AA(LA7AA))
IF 'LA7AA
QUIT
Begin DoDot:1
+21 NEW %DT,DTOUT,LRAA,LRAD,LREND,LRFAN,LRLAN
+22 DO EN^DDIOL("For Accession Area: "_$PIECE($GET(^LRO(68,LA7AA,0)),"^"),"","!!?2")
+23 SET LRAA=LA7AA
DO ADATE^LRWU3
+24 IF Y<1!($GET(DTOUT))
SET LA7QUIT=1
QUIT
+25 SET LA7AA(LA7AA)=$GET(LRAD)
+26 DO LRAN^LRWU3
+27 IF LREND
SET LA7QUIT=1
QUIT
+28 SET LA7AA(LA7AA)=$GET(LRAD)_"^"_$GET(LRFAN)_"^"_$GET(LRLAN)
End DoDot:1
IF LA7QUIT
QUIT
+29 QUIT
+30 ;
+31 ;
ASKPREV() ; Ask if build should exclude tests from building that have previously
+1 ; been removed from a manifest. Allows user to control if tests rebuild
+2 ; onto the same or different manifest.
+3 ;
+4 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+5 ;
+6 SET DIR(0)="YO"
+7 SET DIR("A")="Exclude previously removed tests from building"
+8 SET DIR("B")="YES"
+9 SET DIR("?",1)="Answer 'YES' if you do NOT want tests previously removed"
+10 SET DIR("?",2)="from a manifest to be added to this manifest."
+11 SET DIR("?",3)=" "
+12 SET DIR("?",4)="Answer 'NO' if you WANT tests to be added to this manifest"
+13 SET DIR("?",5)="that were previously removed from a manifest and are"
+14 SET DIR("?")="otherwise eligible to be added."
+15 DO ^DIR
+16 QUIT $SELECT($DATA(DIRUT):-1,1:+Y)
+17 ;
+18 ;
PREV(LA7UID,LA760) ; Determine if test previously removed from a manifest.
+1 ; Checks all manifests for accession/test combination.
+2 ; Call with LA7UID = accession's uid
+3 ; LA760 = file #60 test ien
+4 ;
+5 ; Returns 0 = not previously removed from a manifest
+6 ; 1 = previously removed from a manifest
+7 ;
+8 ; Called by LA7SMB
+9 ;
+10 NEW LA7628,LA762801,LA7FLAG,LA7ROOT,LA7X
+11 ;
+12 SET LA7FLAG=0
+13 IF '$LENGTH($GET(LA7UID))!'(+$GET(LA760))
QUIT LA7FLAG
+14 SET LA7ROOT="^LAHM(62.8,""UID"",LA7UID)"
+15 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
IF $QSUBSCRIPT(LA7ROOT,3)'=LA7UID
QUIT
Begin DoDot:1
+16 ; Manifest and specimen ien
+17 SET LA7628=$QSUBSCRIPT(LA7ROOT,4)
SET LA762801=$QSUBSCRIPT(LA7ROOT,5)
+18 SET LA7X=$GET(^LAHM(62.8,LA7628,10,LA762801,0))
+19 ; Found previous test removal
+20 IF $PIECE(LA7X,"^",2)=LA760
IF $PIECE(LA7X,"^",8)=0
SET LA7FLAG=1
End DoDot:1
IF LA7FLAG
QUIT
+21 QUIT LA7FLAG
+22 ;
+23 ;
DOT(LA7CODE,LA7NCS,LA7UID,LA7628) ; Determine ordered tests
+1 ;
+2 ; Call with LA7CODE = Test code to look up
+3 ; LA7NCS = name of coding system
+4 ; LA7UID = accession's UID
+5 ; LA7628 = ien of shipping manifest in #62.8
+6 ;
+7 ; Returns LA760 = ien of test entry in file #60 if found
+8 ;
+9 ; Given a test code, accession and a shipping manifest finds the
+10 ; file #60 test which is associated with the test code on the manifest.
+11 ;
+12 ; Called from LA7VIN4 to determine ordered test and update shipping event.
+13 NEW LA760,LA764,LA7I,LA7X,LA7Y
+14 ;
+15 SET (LA760,LA764)=0
+16 ; Quit if no code, UID or configuration passed.
+17 IF $GET(LA7CODE)=""!($GET(LA7UID)="")!($GET(LA7628)="")
QUIT LA760
+18 ;
+19 ; Using NLT codes
+20 IF $GET(LA7NCS)="99VA64"
SET LA764=+$ORDER(^LAM("E",LA7CODE,0))
+21 ;
+22 ; Try NLT in case other system is returning NLT codes but not saying so
+23 IF 'LA764
IF $DATA(^LAM("E",LA7CODE))
SET LA764=+$ORDER(^LAM("E",LA7CODE,0))
+24 ;
+25 SET LA7I=0
+26 FOR
SET LA7I=$ORDER(^LAHM(62.8,LA7628,10,"UID",LA7UID,LA7I))
IF 'LA7I
QUIT
Begin DoDot:1
+27 SET LA7X=$GET(^LAHM(62.8,LA7628,10,LA7I,0))
+28 SET LA7Y=$PIECE(LA7X,"^",2)
+29 ; Found match on NLT code
+30 IF LA7Y
IF +$PIECE(^LAB(60,LA7Y,64),"^")=LA764
SET LA760=LA7Y
QUIT
+31 ; Found match on non-VA code
+32 IF LA7CODE=$PIECE($GET(^LAHM(62.8,LA7628,10,LA7I,5)),"^")
SET LA760=LA7Y
End DoDot:1
IF LA760
QUIT
+33 ;
+34 QUIT LA760
