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

PRCSCK1 ;SF-ISC/LJP-CONTINUATION OF PRCSCK ;3-13-92/10:45
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SCP K PRCSJP I $D(PRCSF) S PRCSS=PRCSI
 ;S PRCSS=0 F PRCSSI=1:1 S PRCSS=$O(^PRCS(410,DA,"IT",PRCSS)) Q:PRCSS'>0
 S PRCSCST=$P(^PRCS(410,DA,"IT",PRCSS,0),U,7) I PRCSCST>0 D SCP1
 K PRCSCST,PRCSSI,PRCSSJ,PRCSS Q
SCP0 Q:'$D(^PRCS(410,DA,"IT",1,2,0))
 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
 ;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
SCP4 K ^PRCS(410,DA,12) S ^PRCS(410,DA,12,0)="^410.04P^^"
 S PRCSS=0
 F PRCSSI=1:1 S PRCSS=$O(PRCSSUB(PRCSS)) Q:PRCSS'>0  D SCP41
EX1 K PRCSSI,PRCSS,PRCSTT,PRCSTOT,PRCSSUB
 Q
SCP41 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)
 Q
SCP1 S PRCSS(1)=0
 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
 Q
SCP2 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))
 Q