PRCH69 ;WISC/REW/Revises Vendor ID Nodes Per DBIA 1540 ; [9/25/98 3:54pm]
;;5.0;IFCAP;**69**;4/21/95
;
K ^DD(440,0,"ID") S ^("ID","Z")="G START^PRCHID" ; change ID code
;
FIX ;Here is the start of correcting file 440. The corrections are:
; 1. Remove all leading spaces from Vendor NAME
; 2. Leave only 2 stars (*) in front of INACTIVATED VENDOR NANE
; field.
; 3. Remove any REPLACEMENT VENDOR that points to itself.
; 4. If a chain of REPLACEMENT VENDORs has one that points
; to a previous entry in the chain, remove that REPLACEMENT
; VENDOR.
;
S LOOP=0 ;This is the place holder for the vendor being checked.
F S LOOP=$O(^PRC(440,LOOP)) Q:LOOP'>0 D
. ; Remove all stars (*) and leading spaces (' ').
. S (ONAME,NAME)=$P($G(^PRC(440,LOOP,0)),U,1)
. F D Q:'(X1C=32!(X1C=42))
. . S X1=$E(NAME,1)
. . S X1C=$A(X1)
. . I X1C=32!(X1C=42) S NAME=$E(NAME,2,99)
. . Q
. S $P(^PRC(440,LOOP,0),U,1)=NAME
. ;
. ; Now remove old name from "B" x-ref and replace it with new name
. ; without stars or leading spaces.
. ;
. S NNAME=NAME
. K ^PRC(440,"B",ONAME,LOOP)
. ;
. ; If there is nothing in NNAME, report that to the user and skip
. ; further processing on this record.
. ;
. I NNAME="" D Q
. . S MSG=" "
. . D MES^XPDUTL(MSG)
. . S MSG="After removing leading spaces and/or stars entry "_LOOP_" NAME field"
. . D MES^XPDUTL(MSG)
. . S MSG="has nothing left. This record needs to be checked out."
. . D MES^XPDUTL(MSG)
. . S MSG=" "
. . D MES^XPDUTL(MSG)
. . Q
. ;
. S ^PRC(440,"B",NNAME,LOOP)=""
. ;
. ; Set up sub-loop to check INACTIVATED VENDOR chain.
. ;
. S CLOOP=LOOP
CLOOP . S INACT=$P($G(^PRC(440,CLOOP,10)),U,5)
. I INACT="" K CHAIN Q
. ;
. ; Lets add stars to inactive vendor.
. ; Add inactive vendor to "B" cross reference with stars.
. ; Now the vendor name is in the "B" cross reference with and
. ; without leading stars.
. ;
. I CLOOP=LOOP D
. . S NAME="**"_NAME
. . S $P(^PRC(440,LOOP,0),U,1)=NAME
. . S ^PRC(440,"B",NAME,LOOP)=""
. . Q
. ;
. ;Now check the replacement vendor.
. ;
. S REPV=$P($G(^PRC(440,CLOOP,9)),U,1)
. I REPV="" K CHAIN Q
. I REPV=CLOOP D Q
. . K ^PRC(440,CLOOP,9)
. . K CHAIN
. . S MSG1(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to itself."
. . S MSG1(2)="The REPLACEMENT VENDOR has been removed from this vendor."
. . D MES^XPDUTL(.MSG1)
. . Q
. I $D(CHAIN(REPV))#10=1 D Q
. . K ^PRC(440,CLOOP,9)
. . K CHAIN
. . S MSG2(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to"
. . S MSG2(2)="a previous vendor in this chain. The REPLACEMENT VENDOR"
. . S MSG2(3)=REPV_", has been removed from this vendor."
. . D MES^XPDUTL(.MSG2)
. . Q
. S CHAIN(CLOOP)=""
. S CLOOP=REPV
. G CLOOP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH69 2944 printed Apr 09, 2024@21:11:23 Page 2
PRCH69 ;WISC/REW/Revises Vendor ID Nodes Per DBIA 1540 ; [9/25/98 3:54pm]
+1 ;;5.0;IFCAP;**69**;4/21/95
+2 ;
+3 ; change ID code
KILL ^DD(440,0,"ID")
SET ^("ID","Z")="G START^PRCHID"
+4 ;
FIX ;Here is the start of correcting file 440. The corrections are:
+1 ; 1. Remove all leading spaces from Vendor NAME
+2 ; 2. Leave only 2 stars (*) in front of INACTIVATED VENDOR NANE
+3 ; field.
+4 ; 3. Remove any REPLACEMENT VENDOR that points to itself.
+5 ; 4. If a chain of REPLACEMENT VENDORs has one that points
+6 ; to a previous entry in the chain, remove that REPLACEMENT
+7 ; VENDOR.
+8 ;
+9 ;This is the place holder for the vendor being checked.
SET LOOP=0
+10 FOR
SET LOOP=$ORDER(^PRC(440,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+11 ; Remove all stars (*) and leading spaces (' ').
+12 SET (ONAME,NAME)=$PIECE($GET(^PRC(440,LOOP,0)),U,1)
+13 FOR
Begin DoDot:2
+14 SET X1=$EXTRACT(NAME,1)
+15 SET X1C=$ASCII(X1)
+16 IF X1C=32!(X1C=42)
SET NAME=$EXTRACT(NAME,2,99)
+17 QUIT
End DoDot:2
if '(X1C=32!(X1C=42))
QUIT
+18 SET $PIECE(^PRC(440,LOOP,0),U,1)=NAME
+19 ;
+20 ; Now remove old name from "B" x-ref and replace it with new name
+21 ; without stars or leading spaces.
+22 ;
+23 SET NNAME=NAME
+24 KILL ^PRC(440,"B",ONAME,LOOP)
+25 ;
+26 ; If there is nothing in NNAME, report that to the user and skip
+27 ; further processing on this record.
+28 ;
+29 IF NNAME=""
Begin DoDot:2
+30 SET MSG=" "
+31 DO MES^XPDUTL(MSG)
+32 SET MSG="After removing leading spaces and/or stars entry "_LOOP_" NAME field"
+33 DO MES^XPDUTL(MSG)
+34 SET MSG="has nothing left. This record needs to be checked out."
+35 DO MES^XPDUTL(MSG)
+36 SET MSG=" "
+37 DO MES^XPDUTL(MSG)
+38 QUIT
End DoDot:2
QUIT
+39 ;
+40 SET ^PRC(440,"B",NNAME,LOOP)=""
+41 ;
+42 ; Set up sub-loop to check INACTIVATED VENDOR chain.
+43 ;
+44 SET CLOOP=LOOP
CLOOP SET INACT=$PIECE($GET(^PRC(440,CLOOP,10)),U,5)
+1 IF INACT=""
KILL CHAIN
QUIT
+2 ;
+3 ; Lets add stars to inactive vendor.
+4 ; Add inactive vendor to "B" cross reference with stars.
+5 ; Now the vendor name is in the "B" cross reference with and
+6 ; without leading stars.
+7 ;
+8 IF CLOOP=LOOP
Begin DoDot:2
+9 SET NAME="**"_NAME
+10 SET $PIECE(^PRC(440,LOOP,0),U,1)=NAME
+11 SET ^PRC(440,"B",NAME,LOOP)=""
+12 QUIT
End DoDot:2
+13 ;
+14 ;Now check the replacement vendor.
+15 ;
+16 SET REPV=$PIECE($GET(^PRC(440,CLOOP,9)),U,1)
+17 IF REPV=""
KILL CHAIN
QUIT
+18 IF REPV=CLOOP
Begin DoDot:2
+19 KILL ^PRC(440,CLOOP,9)
+20 KILL CHAIN
+21 SET MSG1(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to itself."
+22 SET MSG1(2)="The REPLACEMENT VENDOR has been removed from this vendor."
+23 DO MES^XPDUTL(.MSG1)
+24 QUIT
End DoDot:2
QUIT
+25 IF $DATA(CHAIN(REPV))#10=1
Begin DoDot:2
+26 KILL ^PRC(440,CLOOP,9)
+27 KILL CHAIN
+28 SET MSG2(1)="Vendor "_CLOOP_" has its REPLACEMENT VENDOR pointing to"
+29 SET MSG2(2)="a previous vendor in this chain. The REPLACEMENT VENDOR"
+30 SET MSG2(3)=REPV_", has been removed from this vendor."
+31 DO MES^XPDUTL(.MSG2)
+32 QUIT
End DoDot:2
QUIT
+33 SET CHAIN(CLOOP)=""
+34 SET CLOOP=REPV
+35 GOTO CLOOP
End DoDot:1
+36 QUIT
