PRCFDA4.m

PRCFDA4 ;(Wash ISC)/LKG-PROCESS INVOICE FOR PAYMENT ;26 SEP 95

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

AUTOACCR ;Check if AutoAccrue field answered

 N PRCFBBY,PRCFW,PRCFY,PRCFZ,MOP,DA,DR,DIE

 S PRCFY=$G(^PRC(442,PRCF("PODA"),10,1,0)),PRCFZ=$P($P(PRCFY,U),".")

 S MOP=$P($G(^PRC(442,PRCF("PODA"),0)),U,2)

 S PRCFZ=$S(PRCFZ?2U:PRCFZ,MOP=2:"SO",MOP=21:"SO",1:"MO")

 Q:PRCFZ'="SO"

 I $P($G(^PRC(442,PRCF("PODA"),23)),U,6)]"" Q

 S PRCFBBY=1700+$E($P($G(^PRC(442,PRCF("PODA"),23)),U,2),1,3)

 I PRCFBBY<$$CVNFY^PRCFD8L("IFCAP",5.0) S PRCFW="NO" G AUTOASK

 S PRCFW="YES"

 I $P(PRCFY,".")=921,";10;60;"[(";"_$P(PRCFY,".",2)_";") D

 . I $P(PRCFY,".",2)=60 S PRCFW="YES" Q

 . S PRCFY=$P(PRCFY,U,4),PRCFY=$S(PRCFY?1.N:$P($G(^PRCF(423,PRCFY,1)),U,3),1:"")

 . S PRCFW=$S(PRCFY=6:"YES",PRCFY=7:"YES",1:"NO")

AUTOASK W !,"As the Service Order associated with this Invoice lacks a value for the",!,"  Auto-Accrue Flag, you will now be asked."

 S DIE=442,DR="30//^S X=PRCFW",DA=PRCF("PODA") D ^DIE

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFDA4   1059     printed  Mar 13, 2025@21:07:37                                                                                                                                                                                                     Page 2

PRCFDA4   ;(Wash ISC)/LKG-PROCESS INVOICE FOR PAYMENT ;26 SEP 95

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

AUTOACCR  ;Check if AutoAccrue field answered

 +1        NEW PRCFBBY,PRCFW,PRCFY,PRCFZ,MOP,DA,DR,DIE

 +2        SET PRCFY=$GET(^PRC(442,PRCF("PODA"),10,1,0))

           SET PRCFZ=$PIECE($PIECE(PRCFY,U),".")

 +3        SET MOP=$PIECE($GET(^PRC(442,PRCF("PODA"),0)),U,2)

 +4        SET PRCFZ=$SELECT(PRCFZ?2U:PRCFZ,MOP=2:"SO",MOP=21:"SO",1:"MO")

 +5        if PRCFZ'="SO"

               QUIT 

 +6        IF $PIECE($GET(^PRC(442,PRCF("PODA"),23)),U,6)]""

               QUIT 

 +7        SET PRCFBBY=1700+$EXTRACT($PIECE($GET(^PRC(442,PRCF("PODA"),23)),U,2),1,3)

 +8        IF PRCFBBY<$$CVNFY^PRCFD8L("IFCAP",5.0)

               SET PRCFW="NO"

               GOTO AUTOASK

 +9        SET PRCFW="YES"

 +10       IF $PIECE(PRCFY,".")=921

               IF ";10;60;"[(";"_$PIECE(PRCFY,".",2)_";")

                   Begin DoDot:1

 +11                   IF $PIECE(PRCFY,".",2)=60

                           SET PRCFW="YES"

                           QUIT 

 +12                   SET PRCFY=$PIECE(PRCFY,U,4)

                       SET PRCFY=$SELECT(PRCFY?1.N:$PIECE($GET(^PRCF(423,PRCFY,1)),U,3),1:"")

 +13                   SET PRCFW=$SELECT(PRCFY=6:"YES",PRCFY=7:"YES",1:"NO")

                   End DoDot:1

AUTOASK    WRITE !,"As the Service Order associated with this Invoice lacks a value for the",!,"  Auto-Accrue Flag, you will now be asked."

 +1        SET DIE=442

           SET DR="30//^S X=PRCFW"

           SET DA=PRCF("PODA")

           DO ^DIE

 +2        QUIT