PRCOEDC ;WISC/DJM-IFCAP EDI ENTRY ROUTINE ;1/26/98 1330
V ;;5.1;IFCAP;**156**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, 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)
;Patch PRC*5.1*156, ONLY calculate PRC("FY") if not numeric
I +PRC("FY")=0 D
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOEDC 977 printed Dec 13, 2024@02:11:49 Page 2
PRCOEDC ;WISC/DJM-IFCAP EDI ENTRY ROUTINE ;1/26/98 1330
V ;;5.1;IFCAP;**156**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
NEW(VAR1,VAR2) NEW A,A1,MO,RECORD,REQUEST,SERVICE,YR
+1 SET A=$GET(^PRC(442,VAR1,0))
if A=""
SET VAR2="ERROR"
if A=""
WRITE !,"NPO0 Zero node of record missing. Unable to check further."
if A=""
QUIT
+2 SET SERVICE=$PIECE(A,U,12)
IF SERVICE>0
SET RECORD=$GET(^PRC(442,VAR1,13,SERVICE,0))
IF RECORD]""
SET REQUEST=$PIECE(RECORD,U,9)
if REQUEST=3
QUIT
+3 SET PRC("SITE")=$PIECE($PIECE(A,U),"-")
SET YR=$EXTRACT(DT,2,3)
SET MO=$EXTRACT(DT,4,5)
+4 ;Patch PRC*5.1*156, ONLY calculate PRC("FY") if not numeric
+5 IF +PRC("FY")=0
Begin DoDot:1
+6 SET PRC("FY")=$EXTRACT(100+$SELECT(+MO>9:YR+1,1:YR),2,3)
End DoDot:1
+7 SET A1=$GET(^PRC(442,VAR1,1))
if A1=""
SET VAR2="ERROR"
if A1=""
WRITE !,"NPO1 Node 1 missing in record."
if A1=""
QUIT
if $PIECE(A1,U,7)=1
QUIT
+8 DO HE^PRCOEC3(VAR1,.VAR2)
+9 DO BI^PRCOEC1(A,VAR1,.VAR2)
+10 DO VE^PRCOEC1(A1,.VAR2)
+11 DO ST^PRCOEC1(A,A1,VAR1,.VAR2)
+12 DO MI^PRCOEC3(VAR1,.VAR2)
+13 DO AC^PRCOEC1(A1,VAR1,.VAR2)
+14 DO IT^PRCOEC2(VAR1,.VAR2)
+15 QUIT
