84 lines
3.7 KiB
Mathematica
84 lines
3.7 KiB
Mathematica
PRCHAMDF ;WIRMFO/DJM/ERC-ENSURE AMENDMENT HAS BEEN CHANGED ;5/10/96
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
CHECK(PRCHPO,PRCHAM,PRCHER) ;CHECK OUT EACH 'CHANGES' ENTRY. IF THERE IS
|
|
;NO DIFFERENCE BETWEEN THE AMENDMENT AND THE ORIGINAL ENTRY A MESSAGE
|
|
;WILL BE DISPLAYED STATING THAT THERE ARE NO CHANGES AND THE AMENDMENT
|
|
;MUST BE EDITED. THERE WILL BE NO OPPORTUNITY TO SIGN OFF THE
|
|
;AMENDMENT AT THIS POINT UNTIL IT HAS BEEN EDITED. AN AMENDMENT WITH
|
|
;ONLY AN AUTHORITY EDIT CHANGE (OTHER THAN 'CANCEL' WILL BE CONSIDERED
|
|
;UNCHANGED.
|
|
N PRCI,DIQ,DIC,PRCJ,J1,J2,J3,J4,DR,VAL,DIE,%X,%Y,DIR,CHECK,DA,FIELD,PRCJ1,VAL1,DIWL,DIWR,DIWF,PRCH0NDE,EXIT,MSG,TYPAM,MSGFLG,PRPAYFLG
|
|
S PRCI=0,MSGFLG=0,PRPAYFLG=0
|
|
S DIQ(0)="I"
|
|
F S PRCI=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI)) Q:PRCI'>0 S DA=PRCHPO,DIC=443.6 D:PRCI>1
|
|
. S PRCJ=$G(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))
|
|
. S J1=$P(PRCJ,U,3)
|
|
. G:J1="" REMOVE
|
|
. S J2=$P(J1,":",2)
|
|
. S J3=$P($P(J1,";",2),":")
|
|
. S J4=$P(J1,";")
|
|
. K DR
|
|
. I J2>0 S DR=J2,DR(J3)=J4,DA(J3)=$P(PRCJ,U,4)
|
|
. I J2="" S DR=J4
|
|
. I $P(PRCJ,U,7)>0 S DIC=J3,DA=$P(PRCJ,U,7)
|
|
. S DIQ="FIELD" D EN^DIQ1
|
|
. I J2=40,J4=1 K ^UTILITY($J,"W"),^TMP($J,"W") S EXIT=0 S VAL1=0,DIWL=1,DIWR=80,DIWF="C80|",PRCJ1=$P(PRCJ,U,4) D G:EXIT=0 REMOVE Q
|
|
. . F S VAL1=$O(FIELD(443.61,PRCJ1,1,VAL1)) Q:VAL1'>0 S X=$G(FIELD(443.61,PRCJ1,1,VAL1)) D ^DIWP
|
|
. . S %X="^UTILITY($J,""W"","
|
|
. . S %Y="^TMP($J,""W"","
|
|
. . D %XY^%RCR
|
|
. . S VAL1=0 K ^UTILITY($J,"W")
|
|
. . F S VAL1=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1)) Q:VAL1'>0 S X=(^(VAL1,0)) D ^DIWP
|
|
. . I ^TMP($J,"W",1)'=^UTILITY($J,"W",1) S EXIT=1 Q
|
|
. . S VAL1=0 F S VAL1=$O(^TMP($J,"W",1,VAL1)) Q:VAL1'>0 I $G(^TMP($J,"W",1,VAL1,0))'=$G(^UTILITY($J,"W",1,VAL1,0)) S EXIT=1 Q
|
|
. . Q
|
|
. S VAL=$G(FIELD($S(J3>0:J3,1:443.6),$S(J3["443.6":$P(PRCJ,U,4),J3["441.7":$P(PRCJ,U,7),1:PRCHPO),J4,"I"))
|
|
. S CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)
|
|
. I CHECK'=VAL,VAL'="" Q
|
|
. I CHECK'=VAL,VAL="" D
|
|
. . S TYPAM=$P($G(PRCJ),U,2)
|
|
. . S MSG=$S(TYPAM=20:"Ship To Address.",TYPAM=25:"Invoice Address.",TYPAM=35:"F.O.B. Point.",1:"")
|
|
. . I TYPAM=33,($P(^PRC(443.6,PRCHPO,5,0),U,4)<1) S MSG="Prompt Payment Terms."
|
|
. . Q
|
|
. I $G(MSG)]"" S MSGFLG=1 D MESS2
|
|
. I $G(TYPAM) I TYPAM=28!(TYPAM=29)!(TYPAM=33) Q
|
|
REMOVE . S DR=".01///@"
|
|
. S DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,"
|
|
. S DA(2)=PRCHPO
|
|
. S DA(1)=PRCHAM
|
|
. S DA=PRCI
|
|
. D ^DIE
|
|
. Q
|
|
;ONCE ALL DUPLICATE HAVE BEEN REMOVED FROM THE AMENDMENT, CHECK
|
|
;THE CHANGES MULTIPLE. IF THERE ARE MORE THAN TWO, OR IF THEY
|
|
;ARE FOR VALID CHANGES THE AMENDMENT MAY BE SIGNED OFF, OTHERWISE
|
|
;A MESSAGE DISPLAYS AND THE AMENDMENT PROCESS EXITS.
|
|
S PRCH0NDE=$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)
|
|
I PRCH0NDE>2 Q
|
|
I PRCH0NDE=2,(MSGFLG=0) D Q
|
|
. I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)=34 D
|
|
. . I $G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,1,1,0))=0 D MESS
|
|
. . Q
|
|
. Q
|
|
I PRCH0NDE<2 D MESS
|
|
Q
|
|
;
|
|
MESS ;DISPLAY MESSAGE IF THERE WERE NO SIGNIFICANT CHANGES MADE IN THE
|
|
;AMENDMENT
|
|
W !!!?5,"The changes which have been made do not constitute an amendment."
|
|
S PRCHER=1
|
|
Q
|
|
MESS2 ;PRINTS MESSAGE IF INV. ADDR., SHIP TO ADDR., PROMPT PAY TERMS OR FOB
|
|
;POINT HAVE BEEN DELETED
|
|
I TYPAM'=33 W !?5,"This amendment is missing it's ",MSG
|
|
I TYPAM=33,('PRPAYFLG) D
|
|
. W !?5,"This amendment is missing it's ",MSG
|
|
. S PRPAYFLG=1
|
|
. S I=0 F I=0:0 S I=$O(^PRC(443.6,PRCHPO,5,I)) Q:I="" S ^PRC(^PRC(443.6,PRCHPO,5,I,0))=^PRC(442,PRCHPO,5,I,0),$P(^PRC(443.6,PRCHPO,5,0),U,4)=I
|
|
I TYPAM=20 S $P(^PRC(443.6,PRCHPO,1),U,3)=$P(^PRC(442,PRCHPO,1),U,3)
|
|
I TYPAM=25 S $P(^PRC(443.6,PRCHPO,12),U,6)=$P(^PRC(442,PRCHPO,12),U,6)
|
|
I TYPAM=35 S $P(^PRC(443.6,PRCHPO,1),U,6)=$P(^PRC(442,PRCHPO,1),U,6)
|
|
S PRCHER=1
|
|
Q
|