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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SUTL 2206 printed Oct 16, 2024@17:40:36 Page 2
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
