source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFDA4.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.0 KB
RevLine 
[613]1PRCFDA4 ;(Wash ISC)/LKG-PROCESS INVOICE FOR PAYMENT ;26 SEP 95
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4AUTOACCR ;Check if AutoAccrue field answered
5 N PRCFBBY,PRCFW,PRCFY,PRCFZ,MOP,DA,DR,DIE
6 S PRCFY=$G(^PRC(442,PRCF("PODA"),10,1,0)),PRCFZ=$P($P(PRCFY,U),".")
7 S MOP=$P($G(^PRC(442,PRCF("PODA"),0)),U,2)
8 S PRCFZ=$S(PRCFZ?2U:PRCFZ,MOP=2:"SO",MOP=21:"SO",1:"MO")
9 Q:PRCFZ'="SO"
10 I $P($G(^PRC(442,PRCF("PODA"),23)),U,6)]"" Q
11 S PRCFBBY=1700+$E($P($G(^PRC(442,PRCF("PODA"),23)),U,2),1,3)
12 I PRCFBBY<$$CVNFY^PRCFD8L("IFCAP",5.0) S PRCFW="NO" G AUTOASK
13 S PRCFW="YES"
14 I $P(PRCFY,".")=921,";10;60;"[(";"_$P(PRCFY,".",2)_";") D
15 . I $P(PRCFY,".",2)=60 S PRCFW="YES" Q
16 . S PRCFY=$P(PRCFY,U,4),PRCFY=$S(PRCFY?1.N:$P($G(^PRCF(423,PRCFY,1)),U,3),1:"")
17 . S PRCFW=$S(PRCFY=6:"YES",PRCFY=7:"YES",1:"NO")
18AUTOASK W !,"As the Service Order associated with this Invoice lacks a value for the",!," Auto-Accrue Flag, you will now be asked."
19 S DIE=442,DR="30//^S X=PRCFW",DA=PRCF("PODA") D ^DIE
20 Q
Note: See TracBrowser for help on using the repository browser.