- 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 Feb 18, 2025@23:43:41 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
