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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSCK1 1639 printed Sep 23, 2025@19:53:23 Page 2
PRCSCK1 ;SF-ISC/LJP-CONTINUATION OF PRCSCK ;3-13-92/10:45
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
SCP KILL PRCSJP
IF $DATA(PRCSF)
SET PRCSS=PRCSI
+1 ;S PRCSS=0 F PRCSSI=1:1 S PRCSS=$O(^PRCS(410,DA,"IT",PRCSS)) Q:PRCSS'>0
+2 SET PRCSCST=$PIECE(^PRCS(410,DA,"IT",PRCSS,0),U,7)
IF PRCSCST>0
DO SCP1
+3 KILL PRCSCST,PRCSSI,PRCSSJ,PRCSS
QUIT
SCP0 if '$DATA(^PRCS(410,DA,"IT",1,2,0))
QUIT
+1 SET PRCSTT=$SELECT($DATA(^PRCS(410,DA,4)):+$PIECE(^(4),U,8),1:"")
if '$DATA(PRCSTOT)
SET PRCSTOT=0
IF +PRCSTOT=+PRCSTT
WRITE !,"Multiple delivery SCP distribution matches transaction dollar amount",!,"No entry is required for SCP Multiple."
SET PRCSJP=1
GOTO SCP4
+2 ;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 KILL ^PRCS(410,DA,12)
SET ^PRCS(410,DA,12,0)="^410.04P^^"
+1 SET PRCSS=0
+2 FOR PRCSSI=1:1
SET PRCSS=$ORDER(PRCSSUB(PRCSS))
if PRCSS'>0
QUIT
DO SCP41
EX1 KILL PRCSSI,PRCSS,PRCSTT,PRCSTOT,PRCSSUB
+1 QUIT
SCP41 SET ^PRCS(410,DA,12,PRCSSI,0)=PRCSS_U_PRCSSUB(PRCSS)
SET ^PRCS(410,DA,12,"AB",PRCSS,PRCSSI)=""
SET ^PRCS(410,"C",PRCSS,DA,PRCSSI)=""
SET $PIECE(^PRCS(410,DA,12,0),U,3,4)=PRCSSI_U_($PIECE(^PRCS(410,DA,12,0),U,4)+1)
+1 QUIT
SCP1 SET PRCSS(1)=0
+1 FOR PRCSSJ=1:1
SET PRCSS(1)=$ORDER(^PRCS(410,DA,"IT",PRCSS,2,PRCSS(1)))
if PRCSS(1)'>0
QUIT
SET PRCSS(2)=^(PRCSS(1),0)
SET PRCSS(0)=$SELECT($DATA(^PRCS(410.6,+$PIECE(PRCSS(2),U,2),0)):^(0),1:"")
SET PRCSS(4)=$PIECE(PRCSS(0),U,4)
SET PRCSS(5)=$PIECE(PRCSS(0),U,5)
IF PRCSS(5)
DO SCP2
+2 QUIT
SCP2 if '$DATA(PRCSSUB(PRCSS(5)))
SET PRCSSUB(PRCSS(5))=0
SET PRCSSUB(PRCSS(5))=PRCSSUB(PRCSS(5))+(PRCSCST*PRCSS(4))
if '$DATA(PRCSTOT)
SET PRCSTOT=0
SET PRCSTOT=PRCSTOT+(PRCSCST*PRCSS(4))
+1 QUIT
