source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSCK1.m@ 1087

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

initial load of WorldVistAEHR
File size: 1.6 KB
RevLine 
[613]1PRCSCK1 ;SF-ISC/LJP-CONTINUATION OF PRCSCK ;3-13-92/10:45
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4SCP K PRCSJP I $D(PRCSF) S PRCSS=PRCSI
5 ;S PRCSS=0 F PRCSSI=1:1 S PRCSS=$O(^PRCS(410,DA,"IT",PRCSS)) Q:PRCSS'>0
6 S PRCSCST=$P(^PRCS(410,DA,"IT",PRCSS,0),U,7) I PRCSCST>0 D SCP1
7 K PRCSCST,PRCSSI,PRCSSJ,PRCSS Q
8SCP0 Q:'$D(^PRCS(410,DA,"IT",1,2,0))
9 S PRCSTT=$S($D(^PRCS(410,DA,4)):+$P(^(4),U,8),1:"") S:'$D(PRCSTOT) PRCSTOT=0 I +PRCSTOT=+PRCSTT W !,"Multiple delivery SCP distribution matches transaction dollar amount",!,"No entry is required for SCP Multiple." S PRCSJP=1 G SCP4
10 ;I +PRCSTOT'=+PRCSTT W !,"Multiple delivery SCP distribution does NOT match transaction dollar amount.",!,"Entry or edit of SCP multiple is needed for a match to occur." G EX1
11SCP4 K ^PRCS(410,DA,12) S ^PRCS(410,DA,12,0)="^410.04P^^"
12 S PRCSS=0
13 F PRCSSI=1:1 S PRCSS=$O(PRCSSUB(PRCSS)) Q:PRCSS'>0 D SCP41
14EX1 K PRCSSI,PRCSS,PRCSTT,PRCSTOT,PRCSSUB
15 Q
16SCP41 S ^PRCS(410,DA,12,PRCSSI,0)=PRCSS_U_PRCSSUB(PRCSS),^PRCS(410,DA,12,"AB",PRCSS,PRCSSI)="",^PRCS(410,"C",PRCSS,DA,PRCSSI)="" S $P(^PRCS(410,DA,12,0),U,3,4)=PRCSSI_U_($P(^PRCS(410,DA,12,0),U,4)+1)
17 Q
18SCP1 S PRCSS(1)=0
19 F PRCSSJ=1:1 S PRCSS(1)=$O(^PRCS(410,DA,"IT",PRCSS,2,PRCSS(1))) Q:PRCSS(1)'>0 S PRCSS(2)=^(PRCSS(1),0),PRCSS(0)=$S($D(^PRCS(410.6,+$P(PRCSS(2),U,2),0)):^(0),1:""),PRCSS(4)=$P(PRCSS(0),U,4),PRCSS(5)=$P(PRCSS(0),U,5) I PRCSS(5) D SCP2
20 Q
21SCP2 S:'$D(PRCSSUB(PRCSS(5))) PRCSSUB(PRCSS(5))=0 S PRCSSUB(PRCSS(5))=PRCSSUB(PRCSS(5))+(PRCSCST*PRCSS(4)) S:'$D(PRCSTOT) PRCSTOT=0 S PRCSTOT=PRCSTOT+(PRCSCST*PRCSS(4))
22 Q
Note: See TracBrowser for help on using the repository browser.