| 1 | LA7SUTL ;DALISC/JMC - Shipping Utility ;5/5/97 14:44
|
|---|
| 2 | ;;5.2;LAB MESSAGING;**27**;Sep 27, 1994
|
|---|
| 3 | Q
|
|---|
| 4 | ;
|
|---|
| 5 | SSCFG(SCR) ; Select shipping configuration
|
|---|
| 6 | ; Call with X = 0 no screen
|
|---|
| 7 | ; = 1 active collecting facilty screen
|
|---|
| 8 | ; = 2 active host facility screen
|
|---|
| 9 | ; Returns Y = 0 (unsuccessful) or ien of entry in file #62.9 ^ .01 field name
|
|---|
| 10 | ;
|
|---|
| 11 | N DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 12 | S DIR(0)="PO^62.9:EM",DIR("A")="Select Shipping Configuration"
|
|---|
| 13 | 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)"
|
|---|
| 14 | D ^DIR
|
|---|
| 15 | I Y<1 S Y=0
|
|---|
| 16 | Q Y
|
|---|
| 17 | ;
|
|---|
| 18 | JULIAN(LA7DT) ; Calculate julian date based on date passed
|
|---|
| 19 | ; Call with X = VA FileMan date.
|
|---|
| 20 | ; Returns Y = julian date justified to 3 digits.
|
|---|
| 21 | N LA7JUL
|
|---|
| 22 | S LA7JUL=$$FMDIFF^XLFDT(LA7DT,$E(LA7DT,1,3)_"0101",1)
|
|---|
| 23 | S LA7JUL=LA7JUL+1
|
|---|
| 24 | I $L(LA7JUL)<3 S LA7JUL=$E("000",1,3-$L(LA7JUL))_LA7JUL
|
|---|
| 25 | Q LA7JUL
|
|---|
| 26 | ;
|
|---|
| 27 | AD(LA7AA) ; Determine current accession date for a given accession area.
|
|---|
| 28 | ; Call with LA7AA = ien of entry in file ACCESSION #68.
|
|---|
| 29 | ; Returns LA7AD = accession date in VA FileMan format
|
|---|
| 30 | ; 0^error message if not valid pointer
|
|---|
| 31 | N LA7AD,X
|
|---|
| 32 | S LA7AA=+$G(LA7AA)
|
|---|
| 33 | I $G(LA7AA)<1 Q "0^No pointer to accession file passed"
|
|---|
| 34 | S DT=$$DT^XLFDT
|
|---|
| 35 | S X=$P($G(^LRO(68,LA7AA,0)),U,3)
|
|---|
| 36 | 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.
|
|---|
| 37 | E S LA7AD="0^No accession transform for this accession area"
|
|---|
| 38 | Q LA7AD
|
|---|
| 39 | TEST(IEN) ;USED FOR THE CATALOG
|
|---|
| 40 | K OUT
|
|---|
| 41 | G:'$D(^LAB(60,IEN,0)) EXIT
|
|---|
| 42 | G:$P(^LAB(60,IEN,0),U,12)="" EXIT
|
|---|
| 43 | S LAFLD=$P(^LAB(60,IEN,0),U,12),LADATA=@(U_LAFLD_0_")")
|
|---|
| 44 | S LATYP=$E($P(LADATA,U,2),1,1)
|
|---|
| 45 | I $L($T(@LATYP)) D @LATYP
|
|---|
| 46 | EXIT ;EXIT
|
|---|
| 47 | K LADES,LAFLD,LATYP,LADATA,LAI,LANUM,LASET
|
|---|
| 48 | S OUT=$G(OUT)
|
|---|
| 49 | Q OUT
|
|---|
| 50 | F ;FREE TEXT
|
|---|
| 51 | S OUT="FREE TEXT "
|
|---|
| 52 | S OUT=OUT_$G(@(U_LAFLD_3_")"))
|
|---|
| 53 | Q
|
|---|
| 54 | N ;NUMERIC
|
|---|
| 55 | S OUT="NUMERIC "
|
|---|
| 56 | S OUT=OUT_$G(@(U_LAFLD_3_")"))
|
|---|
| 57 | Q
|
|---|
| 58 | S ;SET OF CODES
|
|---|
| 59 | S OUT="CODES "
|
|---|
| 60 | S LASET=$P(LADATA,U,3),LANUM=$L(LASET,";")-1
|
|---|
| 61 | Q:LANUM'>0
|
|---|
| 62 | F LAI=1:1:LANUM S LADES=$P(LASET,";",LAI) D
|
|---|
| 63 | .S OUT=OUT_$P(LADES,":",1)_" = "_$P(LADES,":",2)_" "
|
|---|
| 64 | Q
|
|---|
