56 lines
3.5 KiB
Mathematica
56 lines
3.5 KiB
Mathematica
ABSVPPP1 ;EAP ALTOONA HARD-CODED PRINTOUT OF FILE 503339.2 ;5/6/98 11:56 AM
|
|
V ;;4.0;VOLUNTARY TIMEKEEPING;**7,10**;JULY 1994;
|
|
QUEUE S ZTRTN="START^ABSVPPP1" S ZTDESC="VOLUNTARY SERVICE DIRECTORY" D ^ABSVQ Q
|
|
START S ^TMP("ABSVTMP2")="" S P=0 S U="^"
|
|
S J=0 F I=1:1 S J=$O(^ABS(503339.2,J)) Q:'J!(J="") I $D(^ABS(503339.2,J,0)) S Z=^ABS(503339.2,J,0) D SET1
|
|
END K J,ST,Z,I,NUM,P,VS,UP,T,K,ON,TW,ZN,TH,FO,FI,SI
|
|
K A(1),A(2),A(3),M,A(4),C,ZP,S,COM,COMF,FTS,FTSF,ZN1
|
|
K ^TMP("ABSVTMP2") K ^TMP("ABSVTMP1")
|
|
Q
|
|
SET1 ;;;;;;;;;;;;SET ZERO NODE PIECES;;;;;;;;;;
|
|
I $D(^ABS(503339.2,J,1)) S ZN1=^ABS(503339.2,J,1) S COM=$P(ZN1,U,3) S COMF=$P(ZN1,U,6) S FTS=$P(ZN1,U,1) S FTSF=$P(ZN1,U,5)
|
|
S ST=$P(Z,U,2) S NUM=$P(Z,U,1) S VS=$P(Z,U,3) S UP=$P(Z,U,10)
|
|
S P=P+1 I UP]"" S UP=$$FULLDAT^ABSVU2(UP)
|
|
;;;;;;;;;;;;;;;;;;;;FIX ADDRESS PIECES;;;;;;;;;;;;;;;;;;;;;
|
|
S C=$P(Z,U,6) S S=$P(Z,U,7) S ZP=$P(Z,U,8) I S]"" I $D(^DIC(5,S,0)) S S=$P(^DIC(5,S,0),U,1) S A(4)=C_", "_S_" "_ZP
|
|
K A(1),A(2),A(3) S ^TMP("ABSVTMP2",J)=""
|
|
S A(1)=$P(Z,U,4) S A(2)=$P(Z,U,5) S A(3)=$P(Z,U,9)
|
|
K:A(1)="" A(1) K:A(2)="" A(2) K:A(3)="" A(3) F M=1:1:4 S:$D(A(M)) ^TMP("ABSVTMP2",J)=^TMP("ABSVTMP2",J)_A(M)_U
|
|
;;;;;;;;;;;;;;;;;;;;WRITE A LINE;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
W !!!,ST,?43,NUM,?50,"VISN #",VS,?62,"DATE OF LAST UPDATE: ",UP,?107,"PAGE: ",P
|
|
;;;;;;;;;;;;;;;;;;;;;SET STATION MULTIPLE PIECES;;;;;;;;;;;;;;;;;;;;
|
|
K ^TMP("ABSVTMP1") S ^TMP("ABSVTMP1")=""
|
|
S FLAG=0
|
|
I $D(^ABS(503339.2,J,3,0)) S K=0 F T=1:1 S K=$O(^ABS(503339.2,J,3,K)) Q:'K!(K="") I $D(^ABS(503339.2,J,3,K,0)) D
|
|
.S ZN=^ABS(503339.2,J,3,K,0) S ON=$P(ZN,U,1),TW=$P(ZN,U,2),TH=$P(ZN,U,3),FO=$P(ZN,U,4),FI=$P(ZN,U,5),SI=$P(ZN,U,6) S ^TMP("ABSVTMP1")=^TMP("ABSVTMP1")_ON_U_TW_U_TH_U_FO_U_FI_U_SI D SETME S ^TMP("ABSVTMP1")=""
|
|
;;;;IF FLAG = 0 THEN NO SECONDARY STATIONS EXIST;;;;;;;;;;;;
|
|
I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,1)
|
|
I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,2)
|
|
I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,3)
|
|
I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,4)
|
|
I $D(ZN1) W !!,"COMM #: ",COM
|
|
I $D(ZN1) W !,"FTS #: ",FTS
|
|
I $D(ZN1) W !,"COMM FAX #: ",COMF,?30,"FTS FAX #: ",FTSF
|
|
K ZN1
|
|
H 1
|
|
Q
|
|
SETME ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
S FLAG=1
|
|
;;;WRITE ADDRESS WITH FIRST RECORD;;;;;;;;;;;;;;;
|
|
I $D(K) I K=1 W !,$P(^TMP("ABSVTMP2",J),U,1) W ?62,"SEC. STA NAME: " I $D(K) I K=1 I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,2) W ?107,"SEC STA #: ",$P(^TMP("ABSVTMP1"),U,1)
|
|
I $D(K) I K=1 W !,$P(^TMP("ABSVTMP2",J),U,2) W ?62,"SEC STA COMM #: " I $D(K) I K=1 I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,4)
|
|
I $D(K) I K=1 W !,$P(^TMP("ABSVTMP2",J),U,3) W ?62,"SEC STA FTS #: " I $D(K) I K=1 I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,3)
|
|
I $D(K) I K=1 W !,$P(^TMP("ABSVTMP2",J),U,4) W ?62,"SEC STA COMM FAX: " I $D(K) I K=1 I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,6)
|
|
I $D(K) I K=1 W !,?62,"SEC STA FTS FAX: " I $D(K) I K=1 I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,5)
|
|
I $D(ZN1) W !!,"COMM #: ",COM
|
|
I $D(ZN1) W !,"FTS #: ",FTS
|
|
I $D(ZN1) W !,"COMM FAX #: ",COMF,?30,"FTS FAX #: ",FTSF
|
|
K ZN1
|
|
;;;;;; IF MORE THAN 1 RECORD, STOP WRITING ADRESS LINES ;;;;;;;
|
|
I K>1 W !!,?62,"SEC. STA NAME: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,2) W ?107,"SEC STA #: ",$P(^TMP("ABSVTMP1"),U,1)
|
|
I K>1 W ! W ?62,"SEC STA COMM #: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,4)
|
|
I K>1 W ! W ?62,"SEC STA FTS #: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,3)
|
|
I K>1 W ! W ?62,"SEC STA COMM FAX: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,6)
|
|
I K>1 W !,?62,"SEC STA FTS FAX: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,5)
|
|
Q
|