- PSDUTL3 ;BIR/JPW-Utility FM and X-Refs (cont'd) ; 18 Jan 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SAC ;sets 'AC' x-ref on field 10 in file 58.86
- S PSDDRU=+$P(^PSD(58.86,DA,0),"^",2),PSDNL=+$P(^(0),"^",7) I 'PSDDRU!('PSDNL) K PSDDDU,PSDNL Q
- S ^PSD(58.86,"AC",X,PSDNL,PSDDRU,DA)="" K PSDDRU,PSDNL
- Q
- KAC ;kills 'AC' x-ref on field 10 in file 58.86
- S PSDDRU=+$P(^PSD(58.86,DA,0),"^",2),PSDNL=+$P(^(0),"^",7) I 'PSDDRU!('PSDNL) K PSDDRU,PSDNL Q
- K ^PSD(58.86,"AC",X,PSDNL,PSDDRU,DA),PSDDRU,PSDNL
- Q
- SAC1 ;sets 'AC' x-ref on field 1 in file 58.86
- S PSDDAT=+$P(^PSD(58.86,DA,0),"^",11),PSDNL=+$P(^(0),"^",7) I 'PSDDAT!('PSDNL) K PSDDAT,PSDNL Q
- S ^PSD(58.86,"AC",PSDDAT,PSDNL,X,DA)="" K PSDDAT,PSDNL
- Q
- KAC1 ;kills 'AC' x-ref on field 1 in file 58.86
- S PSDDAT=+$P(^PSD(58.86,DA,0),"^",11),PSDNL=+$P(^(0),"^",7) I 'PSDDAT!('PSDNL) K PSDDAT,PSDNL Q
- K ^PSD(58.86,"AC",PSDDAT,PSDNL,X,DA),PSDDAT,PSDNL
- Q
- SAC2 ;sets 'AC' x-ref on field 6 in file 58.86
- S PSDDRU=$P(^PSD(58.86,DA,0),"^",2),PSDDAT=$P(^(0),"^",11) I 'PSDDRU!('PSDDAT) K PSDDRU,PSDDAT Q
- S ^PSD(58.86,"AC",PSDDAT,X,PSDDRU,DA)="" K PSDDAT,PSDDRU
- Q
- KAC2 ;kills 'AC' x-ref on field 6 in file 58.86
- S PSDDRU=$P(^PSD(58.86,DA,0),"^",2),PSDDAT=$P(^(0),"^",11) I 'PSDDRU!('PSDDAT) K PSDDRU,PSDDAT Q
- K ^PSD(58.86,"AC",PSDDAT,X,PSDDRU,DA),PSDDAT,PSDDRU
- Q
- SAD ;sets 'AD' x-ref on field 10 in file 58.86
- S PSDDRU=$P($G(^PSD(58.86,DA,1)),"^"),PSDNL=+$P(^(0),"^",7) I PSDDRU']""!('PSDNL) K PSDDRU,PSDNL Q
- S ^PSD(58.86,"AD",X,PSDNL,PSDDRU,DA)="" K PSDDRU,PSDNL
- Q
- KAD ;kills 'AD' x-ref on field 10 in file 58.86
- S PSDDRU=$P($G(^PSD(58.86,DA,1)),"^"),PSDNL=+$P(^(0),"^",7) I PSDDRU']""!('PSDNL) K PSDDRU,PSDNL Q
- K ^PSD(58.86,"AD",X,PSDNL,PSDDRU,DA),PSDDRU,PSDNL
- Q
- SAD1 ;sets 'AD' x-ref on field 13 in file 58.86
- S PSDDAT=+$P(^PSD(58.86,DA,0),"^",11),PSDNL=+$P(^(0),"^",7) I 'PSDDAT!('PSDNL) K PSDDAT,PSDNL Q
- S ^PSD(58.86,"AD",PSDDAT,PSDNL,X,DA)="" K PSDDAT,PSDNL
- Q
- KAD1 ;kills 'AD' x-ref on field 13 in file 58.86
- S PSDDAT=+$P(^PSD(58.86,DA,0),"^",11),PSDNL=+$P(^(0),"^",7) I 'PSDDAT!('PSDNL) K PSDDAT,PSDNL Q
- K ^PSD(58.86,"AD",PSDDAT,PSDNL,X,DA),PSDDAT,PSDNL
- Q
- SAD2 ;sets 'AD' x-ref on field 6 in file 58.86
- S PSDDRU=$P($G(^PSD(58.86,DA,1)),"^"),PSDDAT=$P(^(0),"^",11) I PSDDRU']""!('PSDDAT) K PSDDRU,PSDDAT Q
- S ^PSD(58.86,"AD",PSDDAT,X,PSDDRU,DA)="" K PSDDAT,PSDDRU
- Q
- KAD2 ;kills 'AD' x-ref on field 6 in file 58.86
- S PSDDRU=$P($G(^PSD(58.86,DA,1)),"^"),PSDDAT=$P(^(0),"^",11) I PSDDRU']""!('PSDDAT) K PSDDRU,PSDDAT Q
- K ^PSD(58.86,"AD",PSDDAT,X,PSDDRU,DA),PSDDAT,PSDDRU
- Q
- SACT7 ;set 'ACT' x-ref on field 37 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=4
- I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
- S ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)="" K PSDNL,PSDDRU,PSDTYPE
- Q
- KACT7 ;kill 'ACT' x-ref on field 37 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDDRU=$P(^(0),"^",5),PSDTYPE=4
- I ('PSDNL)!('PSDDRU)!('PSDTYPE) K PSDNL,PSDDRU,PSDTYPE Q
- K ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDUTL3 3090 printed Feb 18, 2025@23:15:44 Page 2
- PSDUTL3 ;BIR/JPW-Utility FM and X-Refs (cont'd) ; 18 Jan 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SAC ;sets 'AC' x-ref on field 10 in file 58.86
- +1 SET PSDDRU=+$PIECE(^PSD(58.86,DA,0),"^",2)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDRU!('PSDNL)
- KILL PSDDDU,PSDNL
- QUIT
- +2 SET ^PSD(58.86,"AC",X,PSDNL,PSDDRU,DA)=""
- KILL PSDDRU,PSDNL
- +3 QUIT
- KAC ;kills 'AC' x-ref on field 10 in file 58.86
- +1 SET PSDDRU=+$PIECE(^PSD(58.86,DA,0),"^",2)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDRU!('PSDNL)
- KILL PSDDRU,PSDNL
- QUIT
- +2 KILL ^PSD(58.86,"AC",X,PSDNL,PSDDRU,DA),PSDDRU,PSDNL
- +3 QUIT
- SAC1 ;sets 'AC' x-ref on field 1 in file 58.86
- +1 SET PSDDAT=+$PIECE(^PSD(58.86,DA,0),"^",11)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDAT!('PSDNL)
- KILL PSDDAT,PSDNL
- QUIT
- +2 SET ^PSD(58.86,"AC",PSDDAT,PSDNL,X,DA)=""
- KILL PSDDAT,PSDNL
- +3 QUIT
- KAC1 ;kills 'AC' x-ref on field 1 in file 58.86
- +1 SET PSDDAT=+$PIECE(^PSD(58.86,DA,0),"^",11)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDAT!('PSDNL)
- KILL PSDDAT,PSDNL
- QUIT
- +2 KILL ^PSD(58.86,"AC",PSDDAT,PSDNL,X,DA),PSDDAT,PSDNL
- +3 QUIT
- SAC2 ;sets 'AC' x-ref on field 6 in file 58.86
- +1 SET PSDDRU=$PIECE(^PSD(58.86,DA,0),"^",2)
- SET PSDDAT=$PIECE(^(0),"^",11)
- IF 'PSDDRU!('PSDDAT)
- KILL PSDDRU,PSDDAT
- QUIT
- +2 SET ^PSD(58.86,"AC",PSDDAT,X,PSDDRU,DA)=""
- KILL PSDDAT,PSDDRU
- +3 QUIT
- KAC2 ;kills 'AC' x-ref on field 6 in file 58.86
- +1 SET PSDDRU=$PIECE(^PSD(58.86,DA,0),"^",2)
- SET PSDDAT=$PIECE(^(0),"^",11)
- IF 'PSDDRU!('PSDDAT)
- KILL PSDDRU,PSDDAT
- QUIT
- +2 KILL ^PSD(58.86,"AC",PSDDAT,X,PSDDRU,DA),PSDDAT,PSDDRU
- +3 QUIT
- SAD ;sets 'AD' x-ref on field 10 in file 58.86
- +1 SET PSDDRU=$PIECE($GET(^PSD(58.86,DA,1)),"^")
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF PSDDRU']""!('PSDNL)
- KILL PSDDRU,PSDNL
- QUIT
- +2 SET ^PSD(58.86,"AD",X,PSDNL,PSDDRU,DA)=""
- KILL PSDDRU,PSDNL
- +3 QUIT
- KAD ;kills 'AD' x-ref on field 10 in file 58.86
- +1 SET PSDDRU=$PIECE($GET(^PSD(58.86,DA,1)),"^")
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF PSDDRU']""!('PSDNL)
- KILL PSDDRU,PSDNL
- QUIT
- +2 KILL ^PSD(58.86,"AD",X,PSDNL,PSDDRU,DA),PSDDRU,PSDNL
- +3 QUIT
- SAD1 ;sets 'AD' x-ref on field 13 in file 58.86
- +1 SET PSDDAT=+$PIECE(^PSD(58.86,DA,0),"^",11)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDAT!('PSDNL)
- KILL PSDDAT,PSDNL
- QUIT
- +2 SET ^PSD(58.86,"AD",PSDDAT,PSDNL,X,DA)=""
- KILL PSDDAT,PSDNL
- +3 QUIT
- KAD1 ;kills 'AD' x-ref on field 13 in file 58.86
- +1 SET PSDDAT=+$PIECE(^PSD(58.86,DA,0),"^",11)
- SET PSDNL=+$PIECE(^(0),"^",7)
- IF 'PSDDAT!('PSDNL)
- KILL PSDDAT,PSDNL
- QUIT
- +2 KILL ^PSD(58.86,"AD",PSDDAT,PSDNL,X,DA),PSDDAT,PSDNL
- +3 QUIT
- SAD2 ;sets 'AD' x-ref on field 6 in file 58.86
- +1 SET PSDDRU=$PIECE($GET(^PSD(58.86,DA,1)),"^")
- SET PSDDAT=$PIECE(^(0),"^",11)
- IF PSDDRU']""!('PSDDAT)
- KILL PSDDRU,PSDDAT
- QUIT
- +2 SET ^PSD(58.86,"AD",PSDDAT,X,PSDDRU,DA)=""
- KILL PSDDAT,PSDDRU
- +3 QUIT
- KAD2 ;kills 'AD' x-ref on field 6 in file 58.86
- +1 SET PSDDRU=$PIECE($GET(^PSD(58.86,DA,1)),"^")
- SET PSDDAT=$PIECE(^(0),"^",11)
- IF PSDDRU']""!('PSDDAT)
- KILL PSDDRU,PSDDAT
- QUIT
- +2 KILL ^PSD(58.86,"AD",PSDDAT,X,PSDDRU,DA),PSDDAT,PSDDRU
- +3 QUIT
- SACT7 ;set 'ACT' x-ref on field 37 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDDRU=$PIECE(^(0),"^",5)
- SET PSDTYPE=4
- +2 IF ('PSDNL)!('PSDDRU)!('PSDTYPE)
- KILL PSDNL,PSDDRU,PSDTYPE
- QUIT
- +3 SET ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA)=""
- KILL PSDNL,PSDDRU,PSDTYPE
- +4 QUIT
- KACT7 ;kill 'ACT' x-ref on field 37 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDDRU=$PIECE(^(0),"^",5)
- SET PSDTYPE=4
- +2 IF ('PSDNL)!('PSDDRU)!('PSDTYPE)
- KILL PSDNL,PSDDRU,PSDTYPE
- QUIT
- +3 KILL ^PSD(58.81,"ACT",X,PSDNL,PSDDRU,PSDTYPE,DA),PSDNL,PSDDRU,PSDTYPE
- +4 QUIT