source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFAIS.m@ 619

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCFAIS ;WISC/PEH-PACK ISM/EDI TRANSACTIONS INTO 32K SIZE MESSAGES ;5/18/93 09:05
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N PRCFA0,PRCFAS,PRCFAD0,PRCFASEQ,PRCFASIZ,PRCFAS,VAR,LINE,PRCFAN,NAMES
5 S PRCFAN=N,PTYP=$P(^PRCF(423,PRCFAN,"TRANS"),U,4) Q:'$D(^PRCF(423.9,PTYP,0)) I $P(^(0),"^",4)["Y" D
6 .K ADD S ADD=$P($G(^PRCF(423.9,PTYP,0)),U,2) S:ADD]"" XMY(ADD)="" S:$G(PRCFA("EDI"))]"" XMY(PRCFA("EDI"))="" S:$G(PRCFA("ISM"))]"" XMY(PRCFA("ISM"))="" K PRCFA("EDI"),PRCFA("ISM")
7 .K ADD I $D(^PRCF(423.9,PTYP,1,0)) S L=0 F S L=$O(^PRCF(423.9,PTYP,1,L)) Q:L'=+L I $D(^PRCF(423.9,PTYP,1,L,0)) S ADD=$P(^(0),U,1) S XMY(ADD)=""
8 .D USERS,GET
9 .K NAMES S %X="XMY(",%Y="NAMES(" D %XY^%RCR
10 .S (LINE,PRCFASIZ,PRCFAD0)=0,PRCFA0=$G(^PRCF(423,PRCFAN,"CODE",1,0))
11 .F S PRCFAD0=$O(^PRCF(423,PRCFAN,"CODE",PRCFAD0)) Q:PRCFAD0="" S VAR=$G(^(PRCFAD0,0)) D:PRCFASIZ+$L(VAR)>30000 S LINE=LINE+1,^XMB(3.9,XMZ,2,LINE,0)=VAR,PRCFASIZ=PRCFASIZ+$L(VAR)
12 ..S LINE=LINE+1,^XMB(3.9,XMZ,2,LINE,0)="~"
13 ..S $P(PRCFASEQ,"^")=+$G(PRCFASEQ)+1,$P(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ,PRCFASIZ=$L(PRCFA0),LINE=1 D GET Q
14 .S $P(PRCFASEQ,"^")=+$G(PRCFASEQ)+1,$P(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ
15 .D MULTI
16 .S:$D(PRCOPODA) $P(^PRC(442,PRCOPODA,12),"^",10)=XMZ
17 .I $G(PBAT)["" S ZX=$O(^PRCF(421.2,"B",PBAT,0)) Q:ZX=""
18 .S:$D(^PRCF(421.2,ZX,0)) $P(^(0),"^",12)=XMZ,$P(^(0),U,4)=DT,^PRCF(421.2,"D",XMZ,ZX)=""
19 .S PRCOUT=1 K ZX
20 .Q
21 Q
22MULTI ;SET DOUCUMENT/SEQUENCE NUMBERS FOR MESSAGES
23 N PRCFAR,PRCFANOD,PRCFAMSG,PRCFARS,PRCFASE1,PRCFASE2,VAR,I,J,K,L,M,N
24 S PRCFASE2="000"_+$G(PRCFASEQ),PRCFASE2=$E(PRCFASE2,($L(PRCFASE2)-2),$L(PRCFASE2))
25 F PRCFAR=1:1:+$G(PRCFASEQ) S PRCFASE1="000"_PRCFAR,PRCFASE1=$E(PRCFASE1,($L(PRCFASE1)-2),$L(PRCFASE1)),$P(PRCFA0,"^",8,9)=PRCFASE1_"^"_PRCFASE2,PRCFANOD=$P(PRCFASEQ,"^",(PRCFAR+1)) D
26 .S LINE=$P(PRCFANOD,";",1),PRCFAMSG=$P(PRCFANOD,";",2) S ^XMB(3.9,PRCFAMSG,2,0)="^3.92A^"_LINE_"^"_LINE_"^"_DT,^XMB(3.9,PRCFAMSG,2,1,0)=PRCFA0
27 F PRCFAR=1:1:+$G(PRCFASEQ) K XMY S XMZ=$P($P(PRCFASEQ,"^",(PRCFAR+1)),";",2),XMDUZ=DUZ,(XMDUN,XMSUB)="ISMS/EDI BATCH "_PBAT,%X="NAMES(",%Y="XMY(" D %XY^%RCR,ENT1^XMD
28 Q
29USERS ;DEFINE MAILMAN VAR
30 S XMDUZ=DUZ,(XMDUN,XMSUB)="ISMS/EDI BATCH "_PBAT
31 Q
32GET ;GET XMZ VAR FROM MAILMAN
33 F D XMZ^XMA2 Q:XMZ>0 H 5
34 Q
35TX2 ;ENTER HERE TO SEND FEE, FEN, LOG, CAP OR IRS CODE SHEETS.
36 N MM
37 S ZZN=$P(^PRCF(423,N,"TRANS"),U,4),PTYP=$O(^PRCF(423.9,"AC",ZZN,0)) Q:PTYP="" Q:'$D(^PRCF(423.9,PTYP,0)) I $P(^(0),U,4)["Y" D Q
38 .S M1=$P(PBAT,"-",4),M2=$E(M1,1,2)_$E(M1,$L(M1)-2,99),MM=$P(PBAT,"-",1,3)_"-"_M2 K M1,M2
39 .K ZZN,ADD S ADD=$P($G(^PRCF(423.9,PTYP,0)),U,2) S:ADD]"" XMY(ADD)=""
40 .K ADD I $D(^PRCF(423.9,PTYP,1,0)) S L=0 F S L=$O(^PRCF(423.9,PTYP,1,L)) Q:L'=+L I $D(^PRCF(423.9,PTYP,1,L,0)) S ADD=$P(^(0),U),XMY(ADD)=""
41 .S XMDUZ=DUZ,XMSUB="ISMS/EDI BATCH "_MM,XMTEXT="^PRCF(423,"_N_",""CODE""," D XMD
42 .I $G(PBAT)["" S ZX=$O(^PRCF(421.2,"B",PBAT,0)) I ZX="" K ZX Q
43 .S:$D(^PRCF(421.2,ZX,0)) $P(^(0),U,12)=XMZ,$P(^(0),U,4)=DT,^PRCF(421.2,"D",XMZ,ZX)=""
44 .S PRCOUT=1 K ZX Q
45 Q
46XMD N I,J,K,L,M,N
47 D ^XMD
48 S:$D(PRCOPODA) $P(^PRC(442,PRCOPODA,12),U,10)=XMZ
49 Q
Note: See TracBrowser for help on using the repository browser.