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

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PRCHAMDF ;WIRMFO/DJM/ERC-ENSURE AMENDMENT HAS BEEN CHANGED ;5/10/96
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4CHECK(PRCHPO,PRCHAM,PRCHER) ;CHECK OUT EACH 'CHANGES' ENTRY. IF THERE IS
5 ;NO DIFFERENCE BETWEEN THE AMENDMENT AND THE ORIGINAL ENTRY A MESSAGE
6 ;WILL BE DISPLAYED STATING THAT THERE ARE NO CHANGES AND THE AMENDMENT
7 ;MUST BE EDITED. THERE WILL BE NO OPPORTUNITY TO SIGN OFF THE
8 ;AMENDMENT AT THIS POINT UNTIL IT HAS BEEN EDITED. AN AMENDMENT WITH
9 ;ONLY AN AUTHORITY EDIT CHANGE (OTHER THAN 'CANCEL' WILL BE CONSIDERED
10 ;UNCHANGED.
11 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
12 S PRCI=0,MSGFLG=0,PRPAYFLG=0
13 S DIQ(0)="I"
14 F S PRCI=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI)) Q:PRCI'>0 S DA=PRCHPO,DIC=443.6 D:PRCI>1
15 . S PRCJ=$G(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))
16 . S J1=$P(PRCJ,U,3)
17 . G:J1="" REMOVE
18 . S J2=$P(J1,":",2)
19 . S J3=$P($P(J1,";",2),":")
20 . S J4=$P(J1,";")
21 . K DR
22 . I J2>0 S DR=J2,DR(J3)=J4,DA(J3)=$P(PRCJ,U,4)
23 . I J2="" S DR=J4
24 . I $P(PRCJ,U,7)>0 S DIC=J3,DA=$P(PRCJ,U,7)
25 . S DIQ="FIELD" D EN^DIQ1
26 . 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
27 . . F S VAL1=$O(FIELD(443.61,PRCJ1,1,VAL1)) Q:VAL1'>0 S X=$G(FIELD(443.61,PRCJ1,1,VAL1)) D ^DIWP
28 . . S %X="^UTILITY($J,""W"","
29 . . S %Y="^TMP($J,""W"","
30 . . D %XY^%RCR
31 . . S VAL1=0 K ^UTILITY($J,"W")
32 . . F S VAL1=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1)) Q:VAL1'>0 S X=(^(VAL1,0)) D ^DIWP
33 . . I ^TMP($J,"W",1)'=^UTILITY($J,"W",1) S EXIT=1 Q
34 . . 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
35 . . Q
36 . 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"))
37 . S CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)
38 . I CHECK'=VAL,VAL'="" Q
39 . I CHECK'=VAL,VAL="" D
40 . . S TYPAM=$P($G(PRCJ),U,2)
41 . . S MSG=$S(TYPAM=20:"Ship To Address.",TYPAM=25:"Invoice Address.",TYPAM=35:"F.O.B. Point.",1:"")
42 . . I TYPAM=33,($P(^PRC(443.6,PRCHPO,5,0),U,4)<1) S MSG="Prompt Payment Terms."
43 . . Q
44 . I $G(MSG)]"" S MSGFLG=1 D MESS2
45 . I $G(TYPAM) I TYPAM=28!(TYPAM=29)!(TYPAM=33) Q
46REMOVE . S DR=".01///@"
47 . S DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,"
48 . S DA(2)=PRCHPO
49 . S DA(1)=PRCHAM
50 . S DA=PRCI
51 . D ^DIE
52 . Q
53 ;ONCE ALL DUPLICATE HAVE BEEN REMOVED FROM THE AMENDMENT, CHECK
54 ;THE CHANGES MULTIPLE. IF THERE ARE MORE THAN TWO, OR IF THEY
55 ;ARE FOR VALID CHANGES THE AMENDMENT MAY BE SIGNED OFF, OTHERWISE
56 ;A MESSAGE DISPLAYS AND THE AMENDMENT PROCESS EXITS.
57 S PRCH0NDE=$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)
58 I PRCH0NDE>2 Q
59 I PRCH0NDE=2,(MSGFLG=0) D Q
60 . I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)=34 D
61 . . I $G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,1,1,0))=0 D MESS
62 . . Q
63 . Q
64 I PRCH0NDE<2 D MESS
65 Q
66 ;
67MESS ;DISPLAY MESSAGE IF THERE WERE NO SIGNIFICANT CHANGES MADE IN THE
68 ;AMENDMENT
69 W !!!?5,"The changes which have been made do not constitute an amendment."
70 S PRCHER=1
71 Q
72MESS2 ;PRINTS MESSAGE IF INV. ADDR., SHIP TO ADDR., PROMPT PAY TERMS OR FOB
73 ;POINT HAVE BEEN DELETED
74 I TYPAM'=33 W !?5,"This amendment is missing it's ",MSG
75 I TYPAM=33,('PRPAYFLG) D
76 . W !?5,"This amendment is missing it's ",MSG
77 . S PRPAYFLG=1
78 . 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
79 I TYPAM=20 S $P(^PRC(443.6,PRCHPO,1),U,3)=$P(^PRC(442,PRCHPO,1),U,3)
80 I TYPAM=25 S $P(^PRC(443.6,PRCHPO,12),U,6)=$P(^PRC(442,PRCHPO,12),U,6)
81 I TYPAM=35 S $P(^PRC(443.6,PRCHPO,1),U,6)=$P(^PRC(442,PRCHPO,1),U,6)
82 S PRCHER=1
83 Q
Note: See TracBrowser for help on using the repository browser.