- 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 Jan 18, 2025@03:06:55 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