23 lines
1.6 KiB
Mathematica
23 lines
1.6 KiB
Mathematica
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
|