| [613] | 1 | PRCH69 ;WISC/REW/Revises Vendor ID Nodes Per DBIA 1540 ; [9/25/98 3:54pm]
|
|---|
| 2 | ;;5.0;IFCAP;**69**;4/21/95
|
|---|
| 3 | ;
|
|---|
| 4 | K ^DD(440,0,"ID") S ^("ID","Z")="G START^PRCHID" ; change ID code
|
|---|
| 5 | ;
|
|---|
| 6 | FIX ;Here is the start of correcting file 440. The corrections are:
|
|---|
| 7 | ; 1. Remove all leading spaces from Vendor NAME
|
|---|
| 8 | ; 2. Leave only 2 stars (*) in front of INACTIVATED VENDOR NANE
|
|---|
| 9 | ; field.
|
|---|
| 10 | ; 3. Remove any REPLACEMENT VENDOR that points to itself.
|
|---|
| 11 | ; 4. If a chain of REPLACEMENT VENDORs has one that points
|
|---|
| 12 | ; to a previous entry in the chain, remove that REPLACEMENT
|
|---|
| 13 | ; VENDOR.
|
|---|
| 14 | ;
|
|---|
| 15 | S LOOP=0 ;This is the place holder for the vendor being checked.
|
|---|
| 16 | F S LOOP=$O(^PRC(440,LOOP)) Q:LOOP'>0 D
|
|---|
| 17 | . ; Remove all stars (*) and leading spaces (' ').
|
|---|
| 18 | . S (ONAME,NAME)=$P($G(^PRC(440,LOOP,0)),U,1)
|
|---|
| 19 | . F D Q:'(X1C=32!(X1C=42))
|
|---|
| 20 | . . S X1=$E(NAME,1)
|
|---|
| 21 | . . S X1C=$A(X1)
|
|---|
| 22 | . . I X1C=32!(X1C=42) S NAME=$E(NAME,2,99)
|
|---|
| 23 | . . Q
|
|---|
| 24 | . S $P(^PRC(440,LOOP,0),U,1)=NAME
|
|---|
| 25 | . ;
|
|---|
| 26 | . ; Now remove old name from "B" x-ref and replace it with new name
|
|---|
| 27 | . ; without stars or leading spaces.
|
|---|
| 28 | . ;
|
|---|
| 29 | . S NNAME=NAME
|
|---|
| 30 | . K ^PRC(440,"B",ONAME,LOOP)
|
|---|
| 31 | . ;
|
|---|
| 32 | . ; If there is nothing in NNAME, report that to the user and skip
|
|---|
| 33 | . ; further processing on this record.
|
|---|
| 34 | . ;
|
|---|
| 35 | . I NNAME="" D Q
|
|---|
| 36 | . . S MSG=" "
|
|---|
| 37 | . . D MES^XPDUTL(MSG)
|
|---|
| 38 | . . S MSG="After removing leading spaces and/or stars entry "_LOOP_" NAME field"
|
|---|
| 39 | . . D MES^XPDUTL(MSG)
|
|---|
| 40 | . . S MSG="has nothing left. This record needs to be checked out."
|
|---|
| 41 | . . D MES^XPDUTL(MSG)
|
|---|
| 42 | . . S MSG=" "
|
|---|
| 43 | . . D MES^XPDUTL(MSG)
|
|---|
| 44 | . . Q
|
|---|
| 45 | . ;
|
|---|
| 46 | . S ^PRC(440,"B",NNAME,LOOP)=""
|
|---|
| 47 | . ;
|
|---|
| 48 | . ; Set up sub-loop to check INACTIVATED VENDOR chain.
|
|---|
| 49 | . ;
|
|---|
| 50 | . S CLOOP=LOOP
|
|---|
| 51 | CLOOP . S INACT=$P($G(^PRC(440,CLOOP,10)),U,5)
|
|---|
| 52 | . I INACT="" K CHAIN Q
|
|---|
| 53 | . ;
|
|---|
| 54 | . ; Lets add stars to inactive vendor.
|
|---|
| 55 | . ; Add inactive vendor to "B" cross reference with stars.
|
|---|
| 56 | . ; Now the vendor name is in the "B" cross reference with and
|
|---|
| 57 | . ; without leading stars.
|
|---|
| 58 | . ;
|
|---|
| 59 | . I CLOOP=LOOP D
|
|---|
| 60 | . . S NAME="**"_NAME
|
|---|
| 61 | . . S $P(^PRC(440,LOOP,0),U,1)=NAME
|
|---|
| 62 | . . S ^PRC(440,"B",NAME,LOOP)=""
|
|---|
| 63 | . . Q
|
|---|
| 64 | . ;
|
|---|
| 65 | . ;Now check the replacement vendor.
|
|---|
| 66 | . ;
|
|---|
| 67 | . S REPV=$P($G(^PRC(440,CLOOP,9)),U,1)
|
|---|
| 68 | . I REPV="" K CHAIN Q
|
|---|
| 69 | . I REPV=CLOOP D Q
|
|---|
| 70 | . . K ^PRC(440,CLOOP,9)
|
|---|
| 71 | . . K CHAIN
|
|---|
| 72 | . . S MSG1(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to itself."
|
|---|
| 73 | . . S MSG1(2)="The REPLACEMENT VENDOR has been removed from this vendor."
|
|---|
| 74 | . . D MES^XPDUTL(.MSG1)
|
|---|
| 75 | . . Q
|
|---|
| 76 | . I $D(CHAIN(REPV))#10=1 D Q
|
|---|
| 77 | . . K ^PRC(440,CLOOP,9)
|
|---|
| 78 | . . K CHAIN
|
|---|
| 79 | . . S MSG2(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to"
|
|---|
| 80 | . . S MSG2(2)="a previous vendor in this chain. The REPLACEMENT VENDOR"
|
|---|
| 81 | . . S MSG2(3)=REPV_", has been removed from this vendor."
|
|---|
| 82 | . . D MES^XPDUTL(.MSG2)
|
|---|
| 83 | . . Q
|
|---|
| 84 | . S CHAIN(CLOOP)=""
|
|---|
| 85 | . S CLOOP=REPV
|
|---|
| 86 | . G CLOOP
|
|---|
| 87 | Q
|
|---|
