source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH69.m@ 623

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PRCH69 ;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 ;
6FIX ;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
51CLOOP . 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
Note: See TracBrowser for help on using the repository browser.