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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMDF 3839 printed Dec 13, 2024@02:05:44 Page 2
PRCHAMDF ;WIRMFO/DJM/ERC-ENSURE AMENDMENT HAS BEEN CHANGED ;5/10/96
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
CHECK(PRCHPO,PRCHAM,PRCHER) ;CHECK OUT EACH 'CHANGES' ENTRY. IF THERE IS
+1 ;NO DIFFERENCE BETWEEN THE AMENDMENT AND THE ORIGINAL ENTRY A MESSAGE
+2 ;WILL BE DISPLAYED STATING THAT THERE ARE NO CHANGES AND THE AMENDMENT
+3 ;MUST BE EDITED. THERE WILL BE NO OPPORTUNITY TO SIGN OFF THE
+4 ;AMENDMENT AT THIS POINT UNTIL IT HAS BEEN EDITED. AN AMENDMENT WITH
+5 ;ONLY AN AUTHORITY EDIT CHANGE (OTHER THAN 'CANCEL' WILL BE CONSIDERED
+6 ;UNCHANGED.
+7 NEW 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
+8 SET PRCI=0
SET MSGFLG=0
SET PRPAYFLG=0
+9 SET DIQ(0)="I"
+10 FOR
SET PRCI=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI))
if PRCI'>0
QUIT
SET DA=PRCHPO
SET DIC=443.6
if PRCI>1
Begin DoDot:1
+11 SET PRCJ=$GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,0))
+12 SET J1=$PIECE(PRCJ,U,3)
+13 if J1=""
GOTO REMOVE
+14 SET J2=$PIECE(J1,":",2)
+15 SET J3=$PIECE($PIECE(J1,";",2),":")
+16 SET J4=$PIECE(J1,";")
+17 KILL DR
+18 IF J2>0
SET DR=J2
SET DR(J3)=J4
SET DA(J3)=$PIECE(PRCJ,U,4)
+19 IF J2=""
SET DR=J4
+20 IF $PIECE(PRCJ,U,7)>0
SET DIC=J3
SET DA=$PIECE(PRCJ,U,7)
+21 SET DIQ="FIELD"
DO EN^DIQ1
+22 IF J2=40
IF J4=1
KILL ^UTILITY($JOB,"W"),^TMP($JOB,"W")
SET EXIT=0
SET VAL1=0
SET DIWL=1
SET DIWR=80
SET DIWF="C80|"
SET PRCJ1=$PIECE(PRCJ,U,4)
Begin DoDot:2
+23 FOR
SET VAL1=$ORDER(FIELD(443.61,PRCJ1,1,VAL1))
if VAL1'>0
QUIT
SET X=$GET(FIELD(443.61,PRCJ1,1,VAL1))
DO ^DIWP
+24 SET %X="^UTILITY($J,""W"","
+25 SET %Y="^TMP($J,""W"","
+26 DO %XY^%RCR
+27 SET VAL1=0
KILL ^UTILITY($JOB,"W")
+28 FOR
SET VAL1=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,VAL1))
if VAL1'>0
QUIT
SET X=(^(VAL1,0))
DO ^DIWP
+29 IF ^TMP($JOB,"W",1)'=^UTILITY($JOB,"W",1)
SET EXIT=1
QUIT
+30 SET VAL1=0
FOR
SET VAL1=$ORDER(^TMP($JOB,"W",1,VAL1))
if VAL1'>0
QUIT
IF $GET(^TMP($JOB,"W",1,VAL1,0))'=$GET(^UTILITY($JOB,"W",1,VAL1,0))
SET EXIT=1
QUIT
+31 QUIT
End DoDot:2
if EXIT=0
GOTO REMOVE
QUIT
+32 SET VAL=$GET(FIELD($SELECT(J3>0:J3,1:443.6),$SELECT(J3["443.6":$PIECE(PRCJ,U,4),J3["441.7":$PIECE(PRCJ,U,7),1:PRCHPO),J4,"I"))
+33 SET CHECK=^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCI,1,1,0)
+34 IF CHECK'=VAL
IF VAL'=""
QUIT
+35 IF CHECK'=VAL
IF VAL=""
Begin DoDot:2
+36 SET TYPAM=$PIECE($GET(PRCJ),U,2)
+37 SET MSG=$SELECT(TYPAM=20:"Ship To Address.",TYPAM=25:"Invoice Address.",TYPAM=35:"F.O.B. Point.",1:"")
+38 IF TYPAM=33
IF ($PIECE(^PRC(443.6,PRCHPO,5,0),U,4)<1)
SET MSG="Prompt Payment Terms."
+39 QUIT
End DoDot:2
+40 IF $GET(MSG)]""
SET MSGFLG=1
DO MESS2
+41 IF $GET(TYPAM)
IF TYPAM=28!(TYPAM=29)!(TYPAM=33)
QUIT
REMOVE SET DR=".01///@"
+1 SET DIE="^PRC(443.6,"_PRCHPO_",6,"_PRCHAM_",3,"
+2 SET DA(2)=PRCHPO
+3 SET DA(1)=PRCHAM
+4 SET DA=PRCI
+5 DO ^DIE
+6 QUIT
End DoDot:1
+7 ;ONCE ALL DUPLICATE HAVE BEEN REMOVED FROM THE AMENDMENT, CHECK
+8 ;THE CHANGES MULTIPLE. IF THERE ARE MORE THAN TWO, OR IF THEY
+9 ;ARE FOR VALID CHANGES THE AMENDMENT MAY BE SIGNED OFF, OTHERWISE
+10 ;A MESSAGE DISPLAYS AND THE AMENDMENT PROCESS EXITS.
+11 SET PRCH0NDE=$PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)
+12 IF PRCH0NDE>2
QUIT
+13 IF PRCH0NDE=2
IF (MSGFLG=0)
Begin DoDot:1
+14 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)=34
Begin DoDot:2
+15 IF $GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,1,1,0))=0
DO MESS
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
QUIT
+18 IF PRCH0NDE<2
DO MESS
+19 QUIT
+20 ;
MESS ;DISPLAY MESSAGE IF THERE WERE NO SIGNIFICANT CHANGES MADE IN THE
+1 ;AMENDMENT
+2 WRITE !!!?5,"The changes which have been made do not constitute an amendment."
+3 SET PRCHER=1
+4 QUIT
MESS2 ;PRINTS MESSAGE IF INV. ADDR., SHIP TO ADDR., PROMPT PAY TERMS OR FOB
+1 ;POINT HAVE BEEN DELETED
+2 IF TYPAM'=33
WRITE !?5,"This amendment is missing it's ",MSG
+3 IF TYPAM=33
IF ('PRPAYFLG)
Begin DoDot:1
+4 WRITE !?5,"This amendment is missing it's ",MSG
+5 SET PRPAYFLG=1
+6 SET I=0
FOR I=0:0
SET I=$ORDER(^PRC(443.6,PRCHPO,5,I))
if I=""
QUIT
SET ^PRC(^PRC(443.6,PRCHPO,5,I,0))=^PRC(442,PRCHPO,5,I,0)
SET $PIECE(^PRC(443.6,PRCHPO,5,0),U,4)=I
End DoDot:1
+7 IF TYPAM=20
SET $PIECE(^PRC(443.6,PRCHPO,1),U,3)=$PIECE(^PRC(442,PRCHPO,1),U,3)
+8 IF TYPAM=25
SET $PIECE(^PRC(443.6,PRCHPO,12),U,6)=$PIECE(^PRC(442,PRCHPO,12),U,6)
+9 IF TYPAM=35
SET $PIECE(^PRC(443.6,PRCHPO,1),U,6)=$PIECE(^PRC(442,PRCHPO,1),U,6)
+10 SET PRCHER=1
+11 QUIT
