source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMDF.m@ 1389

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