- 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 Mar 13, 2025@21:29:51 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
