source: FOIAVistA/trunk/r/VOLUNTARY_TIMEKEEPING-ABSV/ABSVPPP1.m@ 677

Last change on this file since 677 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.5 KB
Line 
1ABSVPPP1 ;EAP ALTOONA HARD-CODED PRINTOUT OF FILE 503339.2 ;5/6/98 11:56 AM
2V ;;4.0;VOLUNTARY TIMEKEEPING;**7,10**;JULY 1994;
3QUEUE S ZTRTN="START^ABSVPPP1" S ZTDESC="VOLUNTARY SERVICE DIRECTORY" D ^ABSVQ Q
4START S ^TMP("ABSVTMP2")="" S P=0 S U="^"
5 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
6END K J,ST,Z,I,NUM,P,VS,UP,T,K,ON,TW,ZN,TH,FO,FI,SI
7 K A(1),A(2),A(3),M,A(4),C,ZP,S,COM,COMF,FTS,FTSF,ZN1
8 K ^TMP("ABSVTMP2") K ^TMP("ABSVTMP1")
9 Q
10SET1 ;;;;;;;;;;;;SET ZERO NODE PIECES;;;;;;;;;;
11 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)
12 S ST=$P(Z,U,2) S NUM=$P(Z,U,1) S VS=$P(Z,U,3) S UP=$P(Z,U,10)
13 S P=P+1 I UP]"" S UP=$$FULLDAT^ABSVU2(UP)
14 ;;;;;;;;;;;;;;;;;;;;FIX ADDRESS PIECES;;;;;;;;;;;;;;;;;;;;;
15 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
16 K A(1),A(2),A(3) S ^TMP("ABSVTMP2",J)=""
17 S A(1)=$P(Z,U,4) S A(2)=$P(Z,U,5) S A(3)=$P(Z,U,9)
18 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
19 ;;;;;;;;;;;;;;;;;;;;WRITE A LINE;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20 W !!!,ST,?43,NUM,?50,"VISN #",VS,?62,"DATE OF LAST UPDATE: ",UP,?107,"PAGE: ",P
21 ;;;;;;;;;;;;;;;;;;;;;SET STATION MULTIPLE PIECES;;;;;;;;;;;;;;;;;;;;
22 K ^TMP("ABSVTMP1") S ^TMP("ABSVTMP1")=""
23 S FLAG=0
24 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
25 .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")=""
26 ;;;;IF FLAG = 0 THEN NO SECONDARY STATIONS EXIST;;;;;;;;;;;;
27 I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,1)
28 I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,2)
29 I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,3)
30 I FLAG=0 W !,$P(^TMP("ABSVTMP2",J),U,4)
31 I $D(ZN1) W !!,"COMM #: ",COM
32 I $D(ZN1) W !,"FTS #: ",FTS
33 I $D(ZN1) W !,"COMM FAX #: ",COMF,?30,"FTS FAX #: ",FTSF
34 K ZN1
35 H 1
36 Q
37SETME ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 S FLAG=1
39 ;;;WRITE ADDRESS WITH FIRST RECORD;;;;;;;;;;;;;;;
40 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)
41 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)
42 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)
43 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)
44 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)
45 I $D(ZN1) W !!,"COMM #: ",COM
46 I $D(ZN1) W !,"FTS #: ",FTS
47 I $D(ZN1) W !,"COMM FAX #: ",COMF,?30,"FTS FAX #: ",FTSF
48 K ZN1
49 ;;;;;; IF MORE THAN 1 RECORD, STOP WRITING ADRESS LINES ;;;;;;;
50 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)
51 I K>1 W ! W ?62,"SEC STA COMM #: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,4)
52 I K>1 W ! W ?62,"SEC STA FTS #: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,3)
53 I K>1 W ! W ?62,"SEC STA COMM FAX: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,6)
54 I K>1 W !,?62,"SEC STA FTS FAX: " I ^TMP("ABSVTMP1")]"" W $P(^TMP("ABSVTMP1"),U,5)
55 Q
Note: See TracBrowser for help on using the repository browser.