- 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 Feb 18, 2025@23:38:12 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