source: WorldVistAEHR/trunk/r/VOLUNTARY_TIMEKEEPING-ABSV/ABSVPPP1.m@ 691

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