PRC5C1 ;WISC/PLT-PRC5C continue ; 10/13/94 9:13 AM
V ;;5.0;IFCAP;**27**;4/21/95
QUIT ;invalid entry
;
EN(PRCZ) ;PRCZ='FND', 'PCL', 'PAC' OR 'CPF'
N PRCRI,PRCA,PRCB,A
S PRCRI(420.92)=0,PRCERR=""
F S PRCRI(420.92)=$O(^PRCU(420.92,"B",PRCZ,PRCRI(420.92))) Q:'PRCRI(420.92) D
. S PRCA=^PRCU(420.92,PRCRI(420.92),0)
. QUIT:$P(PRCA,"^",7)=""
. S PRCA($P(PRCA,"^",7))=$P(PRCA,"^",4)
. S:$G(PRCB)="" PRCB=$P($P(PRCA,"^",7),"-",2)
. QUIT
S:$G(PRCB)="" PRCB=1
F A=1:1:PRCB S PRCA=A_"-"_PRCB S:$G(PRCA(PRCA))="" PRCERR=1
QUIT
;
EN1 ;check prelode distributed standard dictionaty (prc*4*28 installation)
N A
S PRCERR=""
F A=420.13,420.131:.001:420.138 I '$D(^PRCD(A,0)) S PRCERR=1 QUIT
I 'PRCERR F A=420.14:.01:420.19 I '$D(^PRCD(A,0)) S PRCERR=1 QUIT
I 'PRCERR F A=420.1999 I '$D(^PRCD(A,0)) S PRCERR=1 QUIT
QUIT
;
EN2 ;check fms security code in file 411
N PRCRI
S PRCRI(411)=0 F S PRCRI(411)=$O(^PRC(411,PRCRI(411))) QUIT:PRCRI(411)>999999!'PRCRI(411) I '$P($G(^(PRCRI(411),9)),"^",2) S PRCERR=1 QUIT
QUIT
EN3 ;REINDEX FILE 420 SPECIAL CONTROL POINT "AD"
D EN^DDIOL("REINDEX SPECIAL CONTROL POINT INDEX 'AD' STARTS AT "_$$NOW^PRC5A)
N PRCRI
S PRCRI(420)=0
F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) Q:'PRCRI(420) D
. S PRCRI(420.01)=0
. F S PRCRI(420.01)=$O(^PRC(420,PRCRI(420),1,PRCRI(420.01))) Q:'PRCRI(420.01) D:$P($G(^(PRCRI(420.01),0)),"^",12)
.. N DIK,DA
.. S DIK="^PRC(420,"_PRCRI(420)_",1,",DIK(1)="13^AD"
.. S DA(1)=PRCRI(420),DA=PRCRI(420.01)
.. D EN^DIK
.. QUIT
. QUIT
D EN^DDIOL("REINDEX SPECIAL CONTROL POINT INDEX 'AD' ENDS AT "_$$NOW^PRC5A)
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5C1 1646 printed Sep 23, 2025@19:36:02 Page 2
PRC5C1 ;WISC/PLT-PRC5C continue ; 10/13/94 9:13 AM
V ;;5.0;IFCAP;**27**;4/21/95
+1 ;invalid entry
QUIT
+2 ;
EN(PRCZ) ;PRCZ='FND', 'PCL', 'PAC' OR 'CPF'
+1 NEW PRCRI,PRCA,PRCB,A
+2 SET PRCRI(420.92)=0
SET PRCERR=""
+3 FOR
SET PRCRI(420.92)=$ORDER(^PRCU(420.92,"B",PRCZ,PRCRI(420.92)))
if 'PRCRI(420.92)
QUIT
Begin DoDot:1
+4 SET PRCA=^PRCU(420.92,PRCRI(420.92),0)
+5 if $PIECE(PRCA,"^",7)=""
QUIT
+6 SET PRCA($PIECE(PRCA,"^",7))=$PIECE(PRCA,"^",4)
+7 if $GET(PRCB)=""
SET PRCB=$PIECE($PIECE(PRCA,"^",7),"-",2)
+8 QUIT
End DoDot:1
+9 if $GET(PRCB)=""
SET PRCB=1
+10 FOR A=1:1:PRCB
SET PRCA=A_"-"_PRCB
if $GET(PRCA(PRCA))=""
SET PRCERR=1
+11 QUIT
+12 ;
EN1 ;check prelode distributed standard dictionaty (prc*4*28 installation)
+1 NEW A
+2 SET PRCERR=""
+3 FOR A=420.13,420.131:.001:420.138
IF '$DATA(^PRCD(A,0))
SET PRCERR=1
QUIT
+4 IF 'PRCERR
FOR A=420.14:.01:420.19
IF '$DATA(^PRCD(A,0))
SET PRCERR=1
QUIT
+5 IF 'PRCERR
FOR A=420.1999
IF '$DATA(^PRCD(A,0))
SET PRCERR=1
QUIT
+6 QUIT
+7 ;
EN2 ;check fms security code in file 411
+1 NEW PRCRI
+2 SET PRCRI(411)=0
FOR
SET PRCRI(411)=$ORDER(^PRC(411,PRCRI(411)))
if PRCRI(411)>999999!'PRCRI(411)
QUIT
IF '$PIECE($GET(^(PRCRI(411),9)),"^",2)
SET PRCERR=1
QUIT
+3 QUIT
EN3 ;REINDEX FILE 420 SPECIAL CONTROL POINT "AD"
+1 DO EN^DDIOL("REINDEX SPECIAL CONTROL POINT INDEX 'AD' STARTS AT "_$$NOW^PRC5A)
+2 NEW PRCRI
+3 SET PRCRI(420)=0
+4 FOR
SET PRCRI(420)=$ORDER(^PRC(420,PRCRI(420)))
if 'PRCRI(420)
QUIT
Begin DoDot:1
+5 SET PRCRI(420.01)=0
+6 FOR
SET PRCRI(420.01)=$ORDER(^PRC(420,PRCRI(420),1,PRCRI(420.01)))
if 'PRCRI(420.01)
QUIT
if $PIECE($GET(^(PRCRI(420.01),0)),"^",12)
Begin DoDot:2
+7 NEW DIK,DA
+8 SET DIK="^PRC(420,"_PRCRI(420)_",1,"
SET DIK(1)="13^AD"
+9 SET DA(1)=PRCRI(420)
SET DA=PRCRI(420.01)
+10 DO EN^DIK
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 DO EN^DDIOL("REINDEX SPECIAL CONTROL POINT INDEX 'AD' ENDS AT "_$$NOW^PRC5A)
+14 QUIT
+15 ;
