LA7SUTL.m

LA7SUTL ;DALISC/JMC - Shipping Utility ;5/5/97  14:44

 ;;5.2;LAB MESSAGING;**27**;Sep 27, 1994

 Q

 ;

SSCFG(SCR) ; Select shipping configuration

 ; Call with  X = 0  no screen

 ;              = 1  active collecting facilty screen

 ;              = 2  active host facility screen

 ; Returns    Y = 0 (unsuccessful) or ien of entry in file #62.9 ^ .01 field name

 ;

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

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

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

 D ^DIR

 I Y<1 S Y=0

 Q Y

 ;

JULIAN(LA7DT) ; Calculate julian date based on date passed

 ; Call with X = VA FileMan date.

 ;   Returns Y = julian date justified to 3 digits.

 N LA7JUL

 S LA7JUL=$$FMDIFF^XLFDT(LA7DT,$E(LA7DT,1,3)_"0101",1)

 S LA7JUL=LA7JUL+1

 I $L(LA7JUL)<3 S LA7JUL=$E("000",1,3-$L(LA7JUL))_LA7JUL

 Q LA7JUL

 ;

AD(LA7AA) ; Determine current accession date for a given accession area.

 ; Call with LA7AA = ien of entry in file ACCESSION #68.

 ;   Returns LA7AD = accession date in VA FileMan format

 ;                   0^error message if not valid pointer

 N LA7AD,X

 S LA7AA=+$G(LA7AA)

 I $G(LA7AA)<1 Q "0^No pointer to accession file passed"

 S DT=$$DT^XLFDT

 S X=$P($G(^LRO(68,LA7AA,0)),U,3)

 I $L(X) S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT) ; Calculate accession date based on accession transform.

 E  S LA7AD="0^No accession transform for this accession area"

 Q LA7AD

TEST(IEN) ;USED FOR THE CATALOG 

 K OUT

 G:'$D(^LAB(60,IEN,0)) EXIT

 G:$P(^LAB(60,IEN,0),U,12)="" EXIT

 S LAFLD=$P(^LAB(60,IEN,0),U,12),LADATA=@(U_LAFLD_0_")")

 S LATYP=$E($P(LADATA,U,2),1,1)

 I $L($T(@LATYP)) D @LATYP

EXIT ;EXIT

 K LADES,LAFLD,LATYP,LADATA,LAI,LANUM,LASET

 S OUT=$G(OUT)

 Q OUT

F ;FREE TEXT

 S OUT="FREE TEXT     "

 S OUT=OUT_$G(@(U_LAFLD_3_")"))

 Q

N ;NUMERIC

 S OUT="NUMERIC     "

 S OUT=OUT_$G(@(U_LAFLD_3_")"))

 Q

S ;SET OF CODES

 S OUT="CODES   "

 S LASET=$P(LADATA,U,3),LANUM=$L(LASET,";")-1

 Q:LANUM'>0

 F LAI=1:1:LANUM S LADES=$P(LASET,";",LAI) D

 .S OUT=OUT_$P(LADES,":",1)_" = "_$P(LADES,":",2)_"   "

 Q

LA7SUTL   ;DALISC/JMC - Shipping Utility ;5/5/97  14:44

 +1       ;;5.2;LAB MESSAGING;**27**;Sep 27, 1994

 +2        QUIT 

 +3       ;

SSCFG(SCR) ; Select shipping configuration

 +1       ; Call with  X = 0  no screen

 +2       ;              = 1  active collecting facilty screen

 +3       ;              = 2  active host facility screen

 +4       ; Returns    Y = 0 (unsuccessful) or ien of entry in file #62.9 ^ .01 field name

 +5       ;

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

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

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

 +8        IF SCR

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

 +9        DO ^DIR

 +10       IF Y<1

               SET Y=0

 +11       QUIT Y

 +12      ;

JULIAN(LA7DT) ; Calculate julian date based on date passed

 +1       ; Call with X = VA FileMan date.

 +2       ;   Returns Y = julian date justified to 3 digits.

 +3        NEW LA7JUL

 +4        SET LA7JUL=$$FMDIFF^XLFDT(LA7DT,$EXTRACT(LA7DT,1,3)_"0101",1)

 +5        SET LA7JUL=LA7JUL+1

 +6        IF $LENGTH(LA7JUL)<3

               SET LA7JUL=$EXTRACT("000",1,3-$LENGTH(LA7JUL))_LA7JUL

 +7        QUIT LA7JUL

 +8       ;

AD(LA7AA) ; Determine current accession date for a given accession area.

 +1       ; Call with LA7AA = ien of entry in file ACCESSION #68.

 +2       ;   Returns LA7AD = accession date in VA FileMan format

 +3       ;                   0^error message if not valid pointer

 +4        NEW LA7AD,X

 +5        SET LA7AA=+$GET(LA7AA)

 +6        IF $GET(LA7AA)<1

               QUIT "0^No pointer to accession file passed"

 +7        SET DT=$$DT^XLFDT

 +8        SET X=$PIECE($GET(^LRO(68,LA7AA,0)),U,3)

 +9       ; Calculate accession date based on accession transform.

           IF $LENGTH(X)

               SET LA7AD=$SELECT(X="D":DT,X="M":$EXTRACT(DT,1,5)_"00",X="Y":$EXTRACT(DT,1,3)_"0000",X="Q":$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)

 +10      IF '$TEST

               SET LA7AD="0^No accession transform for this accession area"

 +11       QUIT LA7AD

TEST(IEN) ;USED FOR THE CATALOG 

 +1        KILL OUT

 +2        IF '$DATA(^LAB(60,IEN,0))

               GOTO EXIT

 +3        IF $PIECE(^LAB(60,IEN,0),U,12)=""

               GOTO EXIT

 +4        SET LAFLD=$PIECE(^LAB(60,IEN,0),U,12)

           SET LADATA=@(U_LAFLD_0_")")

 +5        SET LATYP=$EXTRACT($PIECE(LADATA,U,2),1,1)

 +6        IF $LENGTH($TEXT(@LATYP))

               DO @LATYP

EXIT      ;EXIT

 +1        KILL LADES,LAFLD,LATYP,LADATA,LAI,LANUM,LASET

 +2        SET OUT=$GET(OUT)

 +3        QUIT OUT

F         ;FREE TEXT

 +1        SET OUT="FREE TEXT     "

 +2        SET OUT=OUT_$GET(@(U_LAFLD_3_")"))

 +3        QUIT 

N         ;NUMERIC

 +1        SET OUT="NUMERIC     "

 +2        SET OUT=OUT_$GET(@(U_LAFLD_3_")"))

 +3        QUIT 

S         ;SET OF CODES

 +1        SET OUT="CODES   "

 +2        SET LASET=$PIECE(LADATA,U,3)

           SET LANUM=$LENGTH(LASET,";")-1

 +3        IF LANUM'>0

               QUIT 

 +4        FOR LAI=1:1:LANUM

               SET LADES=$PIECE(LASET,";",LAI)

               Begin DoDot:1

 +5                SET OUT=OUT_$PIECE(LADES,":",1)_" = "_$PIECE(LADES,":",2)_"   "

               End DoDot:1

 +6        QUIT