Routine: LA7SBCR2

LA7SBCR2 ;VA/DALOI/JMC - Shipping Barcode Reader Utility ;JUL 06, 2010 3:14 PM

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,1027**;NOV 01, 1997

SITE(LA7,LA7PROM,LA7BAR) ; Setup remote site info.

 ; Input:

 ;                  LA7=array to return values

 ;              LA7PROM=prompt to display to user

 ;               LA7BAR=0/1 using barcode reader

 ; Screen: Second piece of bar-code must = SITE

 ; Returns array LA7()

 ;  If successful ERROR=0

 ;               IDTYPE=source of UID

 ;                  LPC=longitudinal parity check of SM barcode info

 ;               RPSITE=primary sending site ien^name^station number

 ;                RSITE=sending site ien^name^station number

 ;                 SCFG=pointer to shipping configuration (file #62.9)^name

 ;                  SDT=Shipping date/time

 ;                 SMID=shipping manifest id

 ;   unsuccessful ERROR=>0^error message

 N LA7X,X,Y

 ; Initialize array.

 F Y="ERROR","IDTYPE","LPC","RPSITE","RSITE","SCFG","SDT","SMID" S LA7(Y)=""

 S LA7PROM=$G(LA7PROM,"Site")

 I LA7BAR D BAR

 I 'LA7BAR D

 . N DIR,DIRUT,DTOUT,DUOUT,X,Y

 . S DIR(0)="PO^62.9:EM",DIR("A")="Select Shipping Configuration"

 . S DIR("S")="I $P(^LAHM(62.9,Y,0),U,3)=DUZ(2),$P(^LAHM(62.9,Y,0),U,4)"

 . D ^DIR

 . I Y<1 S LA7("ERROR")=1 Q

 . S LA7("SCFG")=Y

 I 'LA7("ERROR") D

 . I LA7("SCFG") D GETSITE Q

 . I 'LA7("SCFG") S LA7("ERROR")=3 Q

 I LA7("ERROR") D

 . S LA7("ERROR")=LA7("ERROR")_"^"_$P($T(ERROR+LA7("ERROR")),";;",2)

GETSITE ; Retrieve site info from institution file for this shipping configuration.

 ; Set ID type from shipping configuration.

 N LRX,LRY,X,Y

 S Y(0)=$G(^LAHM(62.9,+LA7("SCFG"),0))

 S LA7("IDTYPE")=$P(Y(0),"^",5)

 ; *** Remove line when other id types supported. ***

 I LA7("IDTYPE")>1 S LA7("ERROR")=4

 S LRX=$P(Y(0),"^",2)

 S LRY=$$GET1^DIQ(4,LRX_",",.01)

 I LRX,LRY'="" D

 . S LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1)

 . S LA7("RSITE")=LRX_"^"_LRY_"^"_LRY(99)

 E  S LA7("ERROR")=5

 S LRX=$P(Y(0),"^",6)

 S LRY=$$GET1^DIQ(4,LRX_",",.01)

 I LRX,LRY'="" D

 . S LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1)

 . S LA7("RPSITE")=LRX_"^"_LRY_"^"_LRY(99)

 E  S LA7("ERROR")=5

BAR ; Read SM bar code

 N LA7BCS,Y

 S Y=$$RD^LA7SBCR(.LA7PROM,1),LA7=""

 I Y=0 S LA7("ERROR")=1 Q

 I Y<1 S LA7("ERROR")=2 Q

 ; barcode info & longitudinal parity check

 ; original bar code style

 I $E(Y,1,11)="1^STX^SITE^" D

 . S LA7=$P(Y,"STX^SITE^",2)

 . S LA7=$P(LA7,"^ETX",1)

 . S LA7("LPC")=$P(Y,"^ETX",2)

 ; new bar code style

 I $E(Y,1,7)="1^SITE^" D

 . S LA7=$P(Y,"^",3,5)

 . S LA7("LPC")=$P(Y,"^",6)

 . S LA7BCS=1

 I LA7="" S LA7("ERROR")=2 Q

 I $P(LA7,"^")'="" D

 . N X,Y,Z

 . S Z=$$FINDSITE^LA7VHLU2($P(LA7,"^"),2,1)

 . I Z="" S LA7("ERROR")=5 Q

 . S (X,Y)=0

 . F  S X=$O(^LAHM(62.9,"C",Z,X)) Q:'X  D  Q:Y

 . . S X(0)=$G(^LAHM(62.9,X,0))

 . . I $P(X(0),"^",3)=DUZ(2),$P(X(0),"^",4) S LA7("SCFG")=X_"^"_$P(X(0),"^"),Y=1

 ; shipping date/time

 I $P(LA7,"^",2) S LA7("SDT")=$$DT^LA7SBCR($P(LA7,"^",2))

 ; shipping manifest id

 I $P(LA7,"^",3)'="" S LA7("SMID")=$P(LA7,"^",3)

ERROR ;; Code/Text of error messages

1 ;;User timeout/abort;;

2 ;;Incorrect barcode format;;

3 ;;No Shipping Configuration identified in file #62.9;;

4 ;;Sender's Specimen ID source not presently supported;;

5 ;;No entry in INSTITUTION file #4;;

LA7SBCR2  ;VA/DALOI/JMC - Shipping Barcode Reader Utility ;JUL 06, 2010 3:14 PM

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64,1027**;NOV 01, 1997

 +2       ;

 +3        QUIT

 +4       ;

SITE(LA7,LA7PROM,LA7BAR) ; Setup remote site info.

 +1       ; Input:

 +2       ;                  LA7=array to return values

 +3       ;              LA7PROM=prompt to display to user

 +4       ;               LA7BAR=0/1 using barcode reader

 +5       ; Screen: Second piece of bar-code must = SITE

 +6       ; Returns array LA7()

 +7       ;

 +8       ;  If successful ERROR=0

 +9       ;               IDTYPE=source of UID

 +10      ;                  LPC=longitudinal parity check of SM barcode info

 +11      ;               RPSITE=primary sending site ien^name^station number

 +12      ;                RSITE=sending site ien^name^station number

 +13      ;                 SCFG=pointer to shipping configuration (file #62.9)^name

 +14      ;                  SDT=Shipping date/time

 +15      ;                 SMID=shipping manifest id

 +16      ;

 +17      ;   unsuccessful ERROR=>0^error message

 +18      ;

 +19       NEW LA7X,X,Y

 +20      ; Initialize array.

 +21       FOR Y="ERROR","IDTYPE","LPC","RPSITE","RSITE","SCFG","SDT","SMID"

               SET LA7(Y)=""

 +22       SET LA7PROM=$GET(LA7PROM,"Site")

 +23       IF LA7BAR

               DO BAR

 +24      ;

 +25       IF 'LA7BAR

               Begin DoDot:1

 +26               NEW DIR,DIRUT,DTOUT,DUOUT,X,Y

 +27               SET DIR(0)="PO^62.9:EM"

                   SET DIR("A")="Select Shipping Configuration"

 +28               SET DIR("S")="I $P(^LAHM(62.9,Y,0),U,3)=DUZ(2),$P(^LAHM(62.9,Y,0),U,4)"

 +29               DO ^DIR

 +30               IF Y<1

                       SET LA7("ERROR")=1

                       QUIT

 +31               SET LA7("SCFG")=Y

               End DoDot:1

 +32      ;

 +33       IF 'LA7("ERROR")

               Begin DoDot:1

 +34               IF LA7("SCFG")

                       DO GETSITE

                       QUIT

 +35               IF 'LA7("SCFG")

                       SET LA7("ERROR")=3

                       QUIT

               End DoDot:1

 +36      ;

 +37       IF LA7("ERROR")

               Begin DoDot:1

 +38               SET LA7("ERROR")=LA7("ERROR")_"^"_$PIECE($TEXT(ERROR+LA7("ERROR")),";;",2)

               End DoDot:1

 +39      ;

 +40       QUIT

 +41      ;

 +42      ;

GETSITE   ; Retrieve site info from institution file for this shipping configuration.

 +1       ; Set ID type from shipping configuration.

 +2        NEW LRX,LRY,X,Y

 +3        SET Y(0)=$GET(^LAHM(62.9,+LA7("SCFG"),0))

 +4        SET LA7("IDTYPE")=$PIECE(Y(0),"^",5)

 +5       ;

 +6       ; *** Remove line when other id types supported. ***

 +7        IF LA7("IDTYPE")>1

               SET LA7("ERROR")=4

 +8       ;

 +9        SET LRX=$PIECE(Y(0),"^",2)

 +10       SET LRY=$$GET1^DIQ(4,LRX_",",.01)

 +11       IF LRX

               IF LRY'=""

                   Begin DoDot:1

 +12                   SET LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1)

 +13                   SET LA7("RSITE")=LRX_"^"_LRY_"^"_LRY(99)

                   End DoDot:1

 +14      IF '$TEST

               SET LA7("ERROR")=5

 +15      ;

 +16       SET LRX=$PIECE(Y(0),"^",6)

 +17       SET LRY=$$GET1^DIQ(4,LRX_",",.01)

 +18       IF LRX

               IF LRY'=""

                   Begin DoDot:1

 +19                   SET LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1)

 +20                   SET LA7("RPSITE")=LRX_"^"_LRY_"^"_LRY(99)

                   End DoDot:1

 +21      IF '$TEST

               SET LA7("ERROR")=5

 +22       QUIT

 +23      ;

 +24      ;

BAR       ; Read SM bar code

 +1       ;

 +2        NEW LA7BCS,Y

 +3       ;

 +4        SET Y=$$RD^LA7SBCR(.LA7PROM,1)

           SET LA7=""

 +5        IF Y=0

               SET LA7("ERROR")=1

               QUIT

 +6        IF Y<1

               SET LA7("ERROR")=2

               QUIT

 +7       ;

 +8       ; barcode info & longitudinal parity check

 +9       ; original bar code style

 +10       IF $EXTRACT(Y,1,11)="1^STX^SITE^"

               Begin DoDot:1

 +11               SET LA7=$PIECE(Y,"STX^SITE^",2)

 +12               SET LA7=$PIECE(LA7,"^ETX",1)

 +13               SET LA7("LPC")=$PIECE(Y,"^ETX",2)

               End DoDot:1

 +14      ; new bar code style

 +15       IF $EXTRACT(Y,1,7)="1^SITE^"

               Begin DoDot:1

 +16               SET LA7=$PIECE(Y,"^",3,5)

 +17               SET LA7("LPC")=$PIECE(Y,"^",6)

 +18               SET LA7BCS=1

               End DoDot:1

 +19      ;

 +20       IF LA7=""

               SET LA7("ERROR")=2

               QUIT

 +21      ;

 +22       IF $PIECE(LA7,"^")'=""

               Begin DoDot:1

 +23               NEW X,Y,Z

 +24               SET Z=$$FINDSITE^LA7VHLU2($PIECE(LA7,"^"),2,1)

 +25               IF Z=""

                       SET LA7("ERROR")=5

                       QUIT

 +26               SET (X,Y)=0

 +27               FOR

                       SET X=$ORDER(^LAHM(62.9,"C",Z,X))

                       IF 'X

                           QUIT

                       Begin DoDot:2

 +28                       SET X(0)=$GET(^LAHM(62.9,X,0))

 +29                       IF $PIECE(X(0),"^",3)=DUZ(2)

                               IF $PIECE(X(0),"^",4)

                                   SET LA7("SCFG")=X_"^"_$PIECE(X(0),"^")

                                   SET Y=1

                       End DoDot:2

                       IF Y

                           QUIT

               End DoDot:1

 +30      ;

 +31      ; shipping date/time

 +32       IF $PIECE(LA7,"^",2)

               SET LA7("SDT")=$$DT^LA7SBCR($PIECE(LA7,"^",2))

 +33      ;

 +34      ; shipping manifest id

 +35       IF $PIECE(LA7,"^",3)'=""

               SET LA7("SMID")=$PIECE(LA7,"^",3)

 +36      ;

 +37       QUIT

 +38      ;

 +39      ;

ERROR     ;; Code/Text of error messages

1         ;;User timeout/abort;;

2         ;;Incorrect barcode format;;

3         ;;No Shipping Configuration identified in file #62.9;;

4         ;;Sender's Specimen ID source not presently supported;;

5         ;;No entry in INSTITUTION file #4;;

LA7SBCR2.m