PRSATPF ; HISC/REL-File Exceptions ;4/21/93 08:08
;;4.0;PAID;;Sep 21, 1995
FIL ; File Exception
S ESTR=DFN_"^"_X1_"^"_$P(X2,"^",2)_"^"_$P(X2,"^",1)
; First, check if duplicate
F DA=0:0 S DA=$O(^PRST(458.5,"C",DFN,DA)) Q:DA<1 I $P($G(^PRST(458.5,DA,0)),"^",2,5)=ESTR G EX
L +^PRST(458.5,0)
F1 S DA=$P(^PRST(458.5,0),"^",3)+1 I $D(^PRST(458.5,DA)) S $P(^PRST(458.5,0),"^",3)=DA G F1
S X=^PRST(458.5,0),$P(X,"^",3)=DA,$P(X,"^",4)=$P(X,"^",4)+1,^PRST(458.5,0)=X L -^PRST(458.5,0)
S ^PRST(458.5,DA,0)=DA_"^"_ESTR
S ^PRST(458.5,"B",DA,DA)="",^PRST(458.5,"C",DFN,DA)=""
EX Q
REM ; Remove Exception
L +^PRST(458.5,0)
S X=^PRST(458.5,0) S:$P(X,"^",3)=DA $P(X,"^",3)=DA-1 S $P(X,"^",4)=$P(X,"^",4)-1
K ^PRST(458.5,"C",DFN,DA),^PRST(458.5,"B",DA,DA),^PRST(458.5,DA)
S ^PRST(458.5,0)=X L -^PRST(458.5,0) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATPF 825 printed Oct 16, 2024@18:25:33 Page 2
PRSATPF ; HISC/REL-File Exceptions ;4/21/93 08:08
+1 ;;4.0;PAID;;Sep 21, 1995
FIL ; File Exception
+1 SET ESTR=DFN_"^"_X1_"^"_$PIECE(X2,"^",2)_"^"_$PIECE(X2,"^",1)
+2 ; First, check if duplicate
+3 FOR DA=0:0
SET DA=$ORDER(^PRST(458.5,"C",DFN,DA))
if DA<1
QUIT
IF $PIECE($GET(^PRST(458.5,DA,0)),"^",2,5)=ESTR
GOTO EX
+4 LOCK +^PRST(458.5,0)
F1 SET DA=$PIECE(^PRST(458.5,0),"^",3)+1
IF $DATA(^PRST(458.5,DA))
SET $PIECE(^PRST(458.5,0),"^",3)=DA
GOTO F1
+1 SET X=^PRST(458.5,0)
SET $PIECE(X,"^",3)=DA
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
SET ^PRST(458.5,0)=X
LOCK -^PRST(458.5,0)
+2 SET ^PRST(458.5,DA,0)=DA_"^"_ESTR
+3 SET ^PRST(458.5,"B",DA,DA)=""
SET ^PRST(458.5,"C",DFN,DA)=""
EX QUIT
REM ; Remove Exception
+1 LOCK +^PRST(458.5,0)
+2 SET X=^PRST(458.5,0)
if $PIECE(X,"^",3)=DA
SET $PIECE(X,"^",3)=DA-1
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
+3 KILL ^PRST(458.5,"C",DFN,DA),^PRST(458.5,"B",DA,DA),^PRST(458.5,DA)
+4 SET ^PRST(458.5,0)=X
LOCK -^PRST(458.5,0)
QUIT
