18 lines
863 B
Mathematica
18 lines
863 B
Mathematica
PRCOEDC ;WISC/DJM-IFCAP EDI ENTRY ROUTINE ;1/26/98 1330
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
NEW(VAR1,VAR2) N A,A1,MO,RECORD,REQUEST,SERVICE,YR
|
|
S A=$G(^PRC(442,VAR1,0)) S:A="" VAR2="ERROR" W:A="" !,"NPO0 Zero node of record missing. Unable to check further." Q:A=""
|
|
S SERVICE=$P(A,U,12) I SERVICE>0 S RECORD=$G(^PRC(442,VAR1,13,SERVICE,0)) I RECORD]"" S REQUEST=$P(RECORD,U,9) Q:REQUEST=3
|
|
S PRC("SITE")=$P($P(A,U),"-"),YR=$E(DT,2,3),MO=$E(DT,4,5)
|
|
S PRC("FY")=$E(100+$S(+MO>9:YR+1,1:YR),2,3)
|
|
S A1=$G(^PRC(442,VAR1,1)) S:A1="" VAR2="ERROR" W:A1="" !,"NPO1 Node 1 missing in record." Q:A1="" Q:$P(A1,U,7)=1
|
|
D HE^PRCOEC3(VAR1,.VAR2)
|
|
D BI^PRCOEC1(A,VAR1,.VAR2)
|
|
D VE^PRCOEC1(A1,.VAR2)
|
|
D ST^PRCOEC1(A,A1,VAR1,.VAR2)
|
|
D MI^PRCOEC3(VAR1,.VAR2)
|
|
D AC^PRCOEC1(A1,VAR1,.VAR2)
|
|
D IT^PRCOEC2(VAR1,.VAR2)
|
|
Q
|