Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHAMDF

PRCHAMDF.m

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