PRCFAIS ;WISC/PEH-PACK ISM/EDI TRANSACTIONS INTO 32K SIZE MESSAGES ;5/18/93 09:05
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N PRCFA0,PRCFAS,PRCFAD0,PRCFASEQ,PRCFASIZ,PRCFAS,VAR,LINE,PRCFAN,NAMES
S PRCFAN=N,PTYP=$P(^PRCF(423,PRCFAN,"TRANS"),U,4) Q:'$D(^PRCF(423.9,PTYP,0)) I $P(^(0),"^",4)["Y" D
.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")
.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)=""
.D USERS,GET
.K NAMES S %X="XMY(",%Y="NAMES(" D %XY^%RCR
.S (LINE,PRCFASIZ,PRCFAD0)=0,PRCFA0=$G(^PRCF(423,PRCFAN,"CODE",1,0))
.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)
..S LINE=LINE+1,^XMB(3.9,XMZ,2,LINE,0)="~"
..S $P(PRCFASEQ,"^")=+$G(PRCFASEQ)+1,$P(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ,PRCFASIZ=$L(PRCFA0),LINE=1 D GET Q
.S $P(PRCFASEQ,"^")=+$G(PRCFASEQ)+1,$P(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ
.D MULTI
.S:$D(PRCOPODA) $P(^PRC(442,PRCOPODA,12),"^",10)=XMZ
.I $G(PBAT)["" S ZX=$O(^PRCF(421.2,"B",PBAT,0)) Q:ZX=""
.S:$D(^PRCF(421.2,ZX,0)) $P(^(0),"^",12)=XMZ,$P(^(0),U,4)=DT,^PRCF(421.2,"D",XMZ,ZX)=""
.S PRCOUT=1 K ZX
.Q
Q
MULTI ;SET DOUCUMENT/SEQUENCE NUMBERS FOR MESSAGES
N PRCFAR,PRCFANOD,PRCFAMSG,PRCFARS,PRCFASE1,PRCFASE2,VAR,I,J,K,L,M,N
S PRCFASE2="000"_+$G(PRCFASEQ),PRCFASE2=$E(PRCFASE2,($L(PRCFASE2)-2),$L(PRCFASE2))
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
.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
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
Q
USERS ;DEFINE MAILMAN VAR
S XMDUZ=DUZ,(XMDUN,XMSUB)="ISMS/EDI BATCH "_PBAT
Q
GET ;GET XMZ VAR FROM MAILMAN
F D XMZ^XMA2 Q:XMZ>0 H 5
Q
TX2 ;ENTER HERE TO SEND FEE, FEN, LOG, CAP OR IRS CODE SHEETS.
N MM
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
.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
.K ZZN,ADD S ADD=$P($G(^PRCF(423.9,PTYP,0)),U,2) S:ADD]"" XMY(ADD)=""
.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)=""
.S XMDUZ=DUZ,XMSUB="ISMS/EDI BATCH "_MM,XMTEXT="^PRCF(423,"_N_",""CODE""," D XMD
.I $G(PBAT)["" S ZX=$O(^PRCF(421.2,"B",PBAT,0)) I ZX="" K ZX Q
.S:$D(^PRCF(421.2,ZX,0)) $P(^(0),U,12)=XMZ,$P(^(0),U,4)=DT,^PRCF(421.2,"D",XMZ,ZX)=""
.S PRCOUT=1 K ZX Q
Q
XMD N I,J,K,L,M,N
D ^XMD
S:$D(PRCOPODA) $P(^PRC(442,PRCOPODA,12),U,10)=XMZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAIS 3196 printed Oct 16, 2024@18:03:10 Page 2
PRCFAIS ;WISC/PEH-PACK ISM/EDI TRANSACTIONS INTO 32K SIZE MESSAGES ;5/18/93 09:05
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW PRCFA0,PRCFAS,PRCFAD0,PRCFASEQ,PRCFASIZ,PRCFAS,VAR,LINE,PRCFAN,NAMES
+3 SET PRCFAN=N
SET PTYP=$PIECE(^PRCF(423,PRCFAN,"TRANS"),U,4)
if '$DATA(^PRCF(423.9,PTYP,0))
QUIT
IF $PIECE(^(0),"^",4)["Y"
Begin DoDot:1
+4 KILL ADD
SET ADD=$PIECE($GET(^PRCF(423.9,PTYP,0)),U,2)
if ADD]""
SET XMY(ADD)=""
if $GET(PRCFA("EDI"))]""
SET XMY(PRCFA("EDI"))=""
if $GET(PRCFA("ISM"))]""
SET XMY(PRCFA("ISM"))=""
KILL PRCFA("EDI"),PRCFA("ISM")
+5 KILL ADD
IF $DATA(^PRCF(423.9,PTYP,1,0))
SET L=0
FOR
SET L=$ORDER(^PRCF(423.9,PTYP,1,L))
if L'=+L
QUIT
IF $DATA(^PRCF(423.9,PTYP,1,L,0))
SET ADD=$PIECE(^(0),U,1)
SET XMY(ADD)=""
+6 DO USERS
DO GET
+7 KILL NAMES
SET %X="XMY("
SET %Y="NAMES("
DO %XY^%RCR
+8 SET (LINE,PRCFASIZ,PRCFAD0)=0
SET PRCFA0=$GET(^PRCF(423,PRCFAN,"CODE",1,0))
+9 FOR
SET PRCFAD0=$ORDER(^PRCF(423,PRCFAN,"CODE",PRCFAD0))
if PRCFAD0=""
QUIT
SET VAR=$GET(^(PRCFAD0,0))
if PRCFASIZ+$LENGTH(VAR)>30000
Begin DoDot:2
+10 SET LINE=LINE+1
SET ^XMB(3.9,XMZ,2,LINE,0)="~"
+11 SET $PIECE(PRCFASEQ,"^")=+$GET(PRCFASEQ)+1
SET $PIECE(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ
SET PRCFASIZ=$LENGTH(PRCFA0)
SET LINE=1
DO GET
QUIT
End DoDot:2
SET LINE=LINE+1
SET ^XMB(3.9,XMZ,2,LINE,0)=VAR
SET PRCFASIZ=PRCFASIZ+$LENGTH(VAR)
+12 SET $PIECE(PRCFASEQ,"^")=+$GET(PRCFASEQ)+1
SET $PIECE(PRCFASEQ,"^",PRCFASEQ+1)=LINE_";"_XMZ
+13 DO MULTI
+14 if $DATA(PRCOPODA)
SET $PIECE(^PRC(442,PRCOPODA,12),"^",10)=XMZ
+15 IF $GET(PBAT)[""
SET ZX=$ORDER(^PRCF(421.2,"B",PBAT,0))
if ZX=""
QUIT
+16 if $DATA(^PRCF(421.2,ZX,0))
SET $PIECE(^(0),"^",12)=XMZ
SET $PIECE(^(0),U,4)=DT
SET ^PRCF(421.2,"D",XMZ,ZX)=""
+17 SET PRCOUT=1
KILL ZX
+18 QUIT
End DoDot:1
+19 QUIT
MULTI ;SET DOUCUMENT/SEQUENCE NUMBERS FOR MESSAGES
+1 NEW PRCFAR,PRCFANOD,PRCFAMSG,PRCFARS,PRCFASE1,PRCFASE2,VAR,I,J,K,L,M,N
+2 SET PRCFASE2="000"_+$GET(PRCFASEQ)
SET PRCFASE2=$EXTRACT(PRCFASE2,($LENGTH(PRCFASE2)-2),$LENGTH(PRCFASE2))
+3 FOR PRCFAR=1:1:+$GET(PRCFASEQ)
SET PRCFASE1="000"_PRCFAR
SET PRCFASE1=$EXTRACT(PRCFASE1,($LENGTH(PRCFASE1)-2),$LENGTH(PRCFASE1))
SET $PIECE(PRCFA0,"^",8,9)=PRCFASE1_"^"_PRCFASE2
SET PRCFANOD=$PIECE(PRCFASEQ,"^",(PRCFAR+1))
Begin DoDot:1
+4 SET LINE=$PIECE(PRCFANOD,";",1)
SET PRCFAMSG=$PIECE(PRCFANOD,";",2)
SET ^XMB(3.9,PRCFAMSG,2,0)="^3.92A^"_LINE_"^"_LINE_"^"_DT
SET ^XMB(3.9,PRCFAMSG,2,1,0)=PRCFA0
End DoDot:1
+5 FOR PRCFAR=1:1:+$GET(PRCFASEQ)
KILL XMY
SET XMZ=$PIECE($PIECE(PRCFASEQ,"^",(PRCFAR+1)),";",2)
SET XMDUZ=DUZ
SET (XMDUN,XMSUB)="ISMS/EDI BATCH "_PBAT
SET %X="NAMES("
SET %Y="XMY("
DO %XY^%RCR
DO ENT1^XMD
+6 QUIT
USERS ;DEFINE MAILMAN VAR
+1 SET XMDUZ=DUZ
SET (XMDUN,XMSUB)="ISMS/EDI BATCH "_PBAT
+2 QUIT
GET ;GET XMZ VAR FROM MAILMAN
+1 FOR
DO XMZ^XMA2
if XMZ>0
QUIT
HANG 5
+2 QUIT
TX2 ;ENTER HERE TO SEND FEE, FEN, LOG, CAP OR IRS CODE SHEETS.
+1 NEW MM
+2 SET ZZN=$PIECE(^PRCF(423,N,"TRANS"),U,4)
SET PTYP=$ORDER(^PRCF(423.9,"AC",ZZN,0))
if PTYP=""
QUIT
if '$DATA(^PRCF(423.9,PTYP,0))
QUIT
IF $PIECE(^(0),U,4)["Y"
Begin DoDot:1
+3 SET M1=$PIECE(PBAT,"-",4)
SET M2=$EXTRACT(M1,1,2)_$EXTRACT(M1,$LENGTH(M1)-2,99)
SET MM=$PIECE(PBAT,"-",1,3)_"-"_M2
KILL M1,M2
+4 KILL ZZN,ADD
SET ADD=$PIECE($GET(^PRCF(423.9,PTYP,0)),U,2)
if ADD]""
SET XMY(ADD)=""
+5 KILL ADD
IF $DATA(^PRCF(423.9,PTYP,1,0))
SET L=0
FOR
SET L=$ORDER(^PRCF(423.9,PTYP,1,L))
if L'=+L
QUIT
IF $DATA(^PRCF(423.9,PTYP,1,L,0))
SET ADD=$PIECE(^(0),U)
SET XMY(ADD)=""
+6 SET XMDUZ=DUZ
SET XMSUB="ISMS/EDI BATCH "_MM
SET XMTEXT="^PRCF(423,"_N_",""CODE"","
DO XMD
+7 IF $GET(PBAT)[""
SET ZX=$ORDER(^PRCF(421.2,"B",PBAT,0))
IF ZX=""
KILL ZX
QUIT
+8 if $DATA(^PRCF(421.2,ZX,0))
SET $PIECE(^(0),U,12)=XMZ
SET $PIECE(^(0),U,4)=DT
SET ^PRCF(421.2,"D",XMZ,ZX)=""
+9 SET PRCOUT=1
KILL ZX
QUIT
End DoDot:1
QUIT
+10 QUIT
XMD NEW I,J,K,L,M,N
+1 DO ^XMD
+2 if $DATA(PRCOPODA)
SET $PIECE(^PRC(442,PRCOPODA,12),U,10)=XMZ
+3 QUIT
