PRSATPF.m

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 ---PRSATPF   825     printed  Apr 09, 2024@21:27:55                                                                                                                                                                                                      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