- PSDUTL2 ;BIR/JPW-Utility FM and X-Refs (cont'd) ; 6 Sept 92
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SAG ;sets 'AG' xref in file 58.81 (field 11)
- S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
- S ^PSD(58.81,"AG",X,PSDNL,DA)="" K PSDNL
- Q
- KAG ;kills 'AG' x-ref in file 58.81 (field 11)
- S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
- K ^PSD(58.81,"AG",X,PSDNL,DA),PSDNL
- Q
- SAG1 ;set 'AG' x-ref on field 17 in 58.81
- S PSDOST=+$P(^PSD(58.81,DA,0),"^",12) I 'PSDOST K PSDOST Q
- S ^PSD(58.81,"AG",PSDOST,X,DA)="" K PSDOST
- Q
- KAG1 ;kill 'AG' x-ref on field 17 in 58.81
- S PSDOST=+$P(^PSD(58.81,DA,0),"^",12) I 'PSDOST K PSDOST Q
- K ^PSD(58.81,"AG",PSDOST,X,DA),PSDOST
- Q
- SAC ;set 'AC' x-ref on field 1 in 58.87
- S PSDNL=+$P(^PSD(58.87,DA,0),"^",13) I 'PSDNL K PSDNL Q
- S PSDTYPE=+$P(^PSD(58.87,DA,0),"^",12) I 'PSDTYPE K PSDTYPE Q
- S ^PSD(58.87,"AC",PSDTYPE,PSDNL,X,DA)="" K PSDNL,PSDTYPE
- Q
- KAC ;kill 'AC' x-ref on field 1 in 58.87
- S PSDNL=+$P(^PSD(58.87,DA,0),"^",13),PSDTYPE=+$P(^(0),"^",12)
- I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
- K ^PSD(58.87,"AC",PSDTYPE,PSDNL,X,DA),PSDNL,PSDTYPE
- Q
- SAC1 ;set 'AC' x-ref on field 11 in 58.87
- S PSDNL=+$P(^PSD(58.87,DA,0),"^",13),PSDDAT=+$P(^(0),"^",2)
- I 'PSDNL!('PSDDAT) K PSDNL,PSDDAT Q
- S ^PSD(58.87,"AC",X,PSDNL,PSDDAT,DA)="" K PSDNL,PSDDAT
- Q
- KAC1 ;kill 'AC' x-ref on field 11 in 58.87
- S PSDNL=+$P(^PSD(58.87,DA,0),"^",13),PSDDAT=+$P(^(0),"^",2)
- I 'PSDNL!('PSDDAT) K PSDNL,PSDDAT Q
- K ^PSD(58.87,"AC",X,PSDNL,PSDDAT,DA),PSDNL,PSDDAT
- Q
- SAC2 ;set 'AC' x-ref on field 12 in 58.87
- S PSDTYPE=+$P(^PSD(58.87,DA,0),"^",12),PSDDAT=+$P(^(0),"^",2)
- I 'PSDTYPE!('PSDDAT) K PSDTYPE,PSDDAT Q
- S ^PSD(58.87,"AC",PSDTYPE,X,PSDDAT,DA)="" K PSDTYPE,PSDDAT
- Q
- KAC2 ;kill 'AC' x-ref on field 12 in 58.87
- S PSDTYPE=+$P(^PSD(58.87,DA,0),"^",12),PSDDAT=+$P(^(0),"^",2)
- I 'PSDTYPE!('PSDDAT) K PSDTYPE,PSDDAT Q
- K ^PSD(58.87,"AC",PSDTYPE,X,PSDDAT,DA),PSDTYPE,PSDDAT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDUTL2 1963 printed Feb 18, 2025@23:15:43 Page 2
- PSDUTL2 ;BIR/JPW-Utility FM and X-Refs (cont'd) ; 6 Sept 92
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SAG ;sets 'AG' xref in file 58.81 (field 11)
- +1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
- IF 'PSDNL
- KILL PSDNL
- QUIT
- +2 SET ^PSD(58.81,"AG",X,PSDNL,DA)=""
- KILL PSDNL
- +3 QUIT
- KAG ;kills 'AG' x-ref in file 58.81 (field 11)
- +1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
- IF 'PSDNL
- KILL PSDNL
- QUIT
- +2 KILL ^PSD(58.81,"AG",X,PSDNL,DA),PSDNL
- +3 QUIT
- SAG1 ;set 'AG' x-ref on field 17 in 58.81
- +1 SET PSDOST=+$PIECE(^PSD(58.81,DA,0),"^",12)
- IF 'PSDOST
- KILL PSDOST
- QUIT
- +2 SET ^PSD(58.81,"AG",PSDOST,X,DA)=""
- KILL PSDOST
- +3 QUIT
- KAG1 ;kill 'AG' x-ref on field 17 in 58.81
- +1 SET PSDOST=+$PIECE(^PSD(58.81,DA,0),"^",12)
- IF 'PSDOST
- KILL PSDOST
- QUIT
- +2 KILL ^PSD(58.81,"AG",PSDOST,X,DA),PSDOST
- +3 QUIT
- SAC ;set 'AC' x-ref on field 1 in 58.87
- +1 SET PSDNL=+$PIECE(^PSD(58.87,DA,0),"^",13)
- IF 'PSDNL
- KILL PSDNL
- QUIT
- +2 SET PSDTYPE=+$PIECE(^PSD(58.87,DA,0),"^",12)
- IF 'PSDTYPE
- KILL PSDTYPE
- QUIT
- +3 SET ^PSD(58.87,"AC",PSDTYPE,PSDNL,X,DA)=""
- KILL PSDNL,PSDTYPE
- +4 QUIT
- KAC ;kill 'AC' x-ref on field 1 in 58.87
- +1 SET PSDNL=+$PIECE(^PSD(58.87,DA,0),"^",13)
- SET PSDTYPE=+$PIECE(^(0),"^",12)
- +2 IF 'PSDNL!('PSDTYPE)
- KILL PSDNL,PSDTYPE
- QUIT
- +3 KILL ^PSD(58.87,"AC",PSDTYPE,PSDNL,X,DA),PSDNL,PSDTYPE
- +4 QUIT
- SAC1 ;set 'AC' x-ref on field 11 in 58.87
- +1 SET PSDNL=+$PIECE(^PSD(58.87,DA,0),"^",13)
- SET PSDDAT=+$PIECE(^(0),"^",2)
- +2 IF 'PSDNL!('PSDDAT)
- KILL PSDNL,PSDDAT
- QUIT
- +3 SET ^PSD(58.87,"AC",X,PSDNL,PSDDAT,DA)=""
- KILL PSDNL,PSDDAT
- +4 QUIT
- KAC1 ;kill 'AC' x-ref on field 11 in 58.87
- +1 SET PSDNL=+$PIECE(^PSD(58.87,DA,0),"^",13)
- SET PSDDAT=+$PIECE(^(0),"^",2)
- +2 IF 'PSDNL!('PSDDAT)
- KILL PSDNL,PSDDAT
- QUIT
- +3 KILL ^PSD(58.87,"AC",X,PSDNL,PSDDAT,DA),PSDNL,PSDDAT
- +4 QUIT
- SAC2 ;set 'AC' x-ref on field 12 in 58.87
- +1 SET PSDTYPE=+$PIECE(^PSD(58.87,DA,0),"^",12)
- SET PSDDAT=+$PIECE(^(0),"^",2)
- +2 IF 'PSDTYPE!('PSDDAT)
- KILL PSDTYPE,PSDDAT
- QUIT
- +3 SET ^PSD(58.87,"AC",PSDTYPE,X,PSDDAT,DA)=""
- KILL PSDTYPE,PSDDAT
- +4 QUIT
- KAC2 ;kill 'AC' x-ref on field 12 in 58.87
- +1 SET PSDTYPE=+$PIECE(^PSD(58.87,DA,0),"^",12)
- SET PSDDAT=+$PIECE(^(0),"^",2)
- +2 IF 'PSDTYPE!('PSDDAT)
- KILL PSDTYPE,PSDDAT
- QUIT
- +3 KILL ^PSD(58.87,"AC",PSDTYPE,X,PSDDAT,DA),PSDTYPE,PSDDAT
- +4 QUIT