PRCOEDC.m

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 ---PRCOEDC   977     printed  Apr 09, 2024@21:02:33                                                                                                                                                                                                      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