- PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
- K PSDFLAG I '$D(^PSD(58.8,DA(2),1,DA(1),"I")) S PSDFLAG=1 Q
- S:$O(^PSD(58.8,DA(2),1,DA(1),"I"))>DT PSDFLAG=1
- Q
- DELR ;deletes inactivation reason when inactivation date deleted
- I $D(^PSD(58.8,DA(1),1,DA,0)),'$P(^(0),"^",14) S $P(^(0),"^",15,16)="^"
- Q
- IG ;reset sort keys for inventory groups
- F INVGRP=0:0 S INVGRP=$O(^PSI(58.2,INVGRP)) Q:'INVGRP I $O(^PSI(58.2,INVGRP,3,"D",0)) W "." D IGSET
- K INVGRP
- Q
- IGSET S CNT=0 F SK=0:0 S SK=$O(^PSI(58.2,INVGRP,3,"D",SK)) Q:'SK S NAOU=$O(^PSI(58.2,INVGRP,3,"D",SK,0)),CNT=CNT+1,NAOULP(CNT)=NAOU
- F SK=0:0 S SK=$O(NAOULP(SK)) Q:'SK S NSK=SK*100,DA(1)=INVGRP,DA=NAOULP(SK),DIE="^PSI(58.2,"_DA(1)_",3,",DR="2///"_NSK D ^DIE K DIE
- K D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
- Q
- NAOU ;checks for NAOU inpatient site
- S SITE=0
- I '$P($G(^PSD(58.8,PSDA,0)),"^",3) W !!,"You must define a CS inpatient site for this NAOU.",!,"Use the 'Create the Narcotic Area of Use' option to add this data.",!!,"Press <RET> to continue " R X:DTIME S SITE=1 W @IOF
- K X
- Q
- STAT ;sets order status cross-reference in file 58.85 (field 6)
- N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
- Q:'PSDNL!('PSDD)!('PSDREQ)
- S ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
- Q
- KSTAT ;kills order status cross-reference in file 58.85 (field 6)
- N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
- Q:'PSDNL!('PSDD)!('PSDREQ)
- K ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
- Q
- REQ ;sets request # x-ref in file 58.85 (field 4)
- N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
- Q:'PSDNL!('PSDD)
- S ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
- Q
- KREQ ;kills request # x-ref in file 58.85 (field 4)
- N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
- Q:'PSDNL!('PSDD)
- K ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
- Q
- SAD ;sets 'AD' xref in file 58.81 (field 10)
- S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
- S ^PSD(58.81,"AD",X,PSDNL,DA)="" K PSDNL
- Q
- KAD ;kills 'AD' x-ref in file 58.81 (field 10)
- S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
- K ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
- Q
- SAF ;set 'AF' x-ref on field 3 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
- I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
- S ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)="" K PSDNL,PSDTYPE
- Q
- KAF ;kill 'AF' x-ref on field 3 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
- I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
- K ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
- Q
- SAFL ;set 'AF' (for loc) on field 3 in 58.81
- S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
- I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
- S ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)="" K PSDATT,PSDTYPE
- Q
- KAFL ;kill 'AF' (for loc) on field 3 in 58.81
- S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
- I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
- K ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
- Q
- SASITE ;set 'ASITE' x-ref on field 2 in 58.8
- Q:$P(^PSD(58.8,DA,0),"^",2)=""
- S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
- S ^PSD(58.8,"ASITE",X,PSDTYPE,DA)="" K PSDTYPE
- Q
- KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
- Q:$P(^PSD(58.8,DA,0),"^",2)=""
- S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
- K ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
- Q
- SASITE1 ;set 'ASITE' x-ref on field 1
- S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
- S ^PSD(58.8,"ASITE",PSDDS,X,DA)="" K PSDDS
- Q
- KASITE1 ;k 'ASITE' on field 1 in 58.8
- S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
- K ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
- Q
- SAFT ;set 'AF' field 1 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
- I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
- S ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)="" K PSDATT,PSDNL
- Q
- KAFT ;kill 'AF' field 1 in 58.81
- S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
- I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
- K ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDUTL 4187 printed Feb 18, 2025@23:15:41 Page 2
- PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
- +1 KILL PSDFLAG
- IF '$DATA(^PSD(58.8,DA(2),1,DA(1),"I"))
- SET PSDFLAG=1
- QUIT
- +2 if $ORDER(^PSD(58.8,DA(2),1,DA(1),"I"))>DT
- SET PSDFLAG=1
- +3 QUIT
- DELR ;deletes inactivation reason when inactivation date deleted
- +1 IF $DATA(^PSD(58.8,DA(1),1,DA,0))
- IF '$PIECE(^(0),"^",14)
- SET $PIECE(^(0),"^",15,16)="^"
- +2 QUIT
- IG ;reset sort keys for inventory groups
- +1 FOR INVGRP=0:0
- SET INVGRP=$ORDER(^PSI(58.2,INVGRP))
- if 'INVGRP
- QUIT
- IF $ORDER(^PSI(58.2,INVGRP,3,"D",0))
- WRITE "."
- DO IGSET
- +2 KILL INVGRP
- +3 QUIT
- IGSET SET CNT=0
- FOR SK=0:0
- SET SK=$ORDER(^PSI(58.2,INVGRP,3,"D",SK))
- if 'SK
- QUIT
- SET NAOU=$ORDER(^PSI(58.2,INVGRP,3,"D",SK,0))
- SET CNT=CNT+1
- SET NAOULP(CNT)=NAOU
- +1 FOR SK=0:0
- SET SK=$ORDER(NAOULP(SK))
- if 'SK
- QUIT
- SET NSK=SK*100
- SET DA(1)=INVGRP
- SET DA=NAOULP(SK)
- SET DIE="^PSI(58.2,"_DA(1)_",3,"
- SET DR="2///"_NSK
- DO ^DIE
- KILL DIE
- +2 KILL D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
- +3 QUIT
- NAOU ;checks for NAOU inpatient site
- +1 SET SITE=0
- +2 IF '$PIECE($GET(^PSD(58.8,PSDA,0)),"^",3)
- WRITE !!,"You must define a CS inpatient site for this NAOU.",!,"Use the 'Create the Narcotic Area of Use' option to add this data.",!!,"Press <RET> to continue "
- READ X:DTIME
- SET SITE=1
- WRITE @IOF
- +3 KILL X
- +4 QUIT
- STAT ;sets order status cross-reference in file 58.85 (field 6)
- +1 NEW PSDNL,PSDD,PSDREQ
- SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
- SET PSDD=$PIECE(^(0),"^",4)
- SET PSDREQ=$PIECE(^(0),"^",5)
- +2 if 'PSDNL!('PSDD)!('PSDREQ)
- QUIT
- +3 SET ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
- +4 QUIT
- KSTAT ;kills order status cross-reference in file 58.85 (field 6)
- +1 NEW PSDNL,PSDD,PSDREQ
- SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
- SET PSDD=$PIECE(^(0),"^",4)
- SET PSDREQ=$PIECE(^(0),"^",5)
- +2 if 'PSDNL!('PSDD)!('PSDREQ)
- QUIT
- +3 KILL ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
- +4 QUIT
- REQ ;sets request # x-ref in file 58.85 (field 4)
- +1 NEW PSDNL,PSDD
- SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
- SET PSDD=$PIECE(^(0),"^",4)
- +2 if 'PSDNL!('PSDD)
- QUIT
- +3 SET ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
- +4 QUIT
- KREQ ;kills request # x-ref in file 58.85 (field 4)
- +1 NEW PSDNL,PSDD
- SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
- SET PSDD=$PIECE(^(0),"^",4)
- +2 if 'PSDNL!('PSDD)
- QUIT
- +3 KILL ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
- +4 QUIT
- SAD ;sets 'AD' xref in file 58.81 (field 10)
- +1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
- IF 'PSDNL
- KILL PSDNL
- QUIT
- +2 SET ^PSD(58.81,"AD",X,PSDNL,DA)=""
- KILL PSDNL
- +3 QUIT
- KAD ;kills 'AD' x-ref in file 58.81 (field 10)
- +1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
- IF 'PSDNL
- KILL PSDNL
- QUIT
- +2 KILL ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
- +3 QUIT
- SAF ;set 'AF' x-ref on field 3 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDTYPE=$PIECE(^(0),"^",2)
- +2 IF 'PSDNL!('PSDTYPE)
- KILL PSDNL,PSDTYPE
- QUIT
- +3 SET ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)=""
- KILL PSDNL,PSDTYPE
- +4 QUIT
- KAF ;kill 'AF' x-ref on field 3 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDTYPE=$PIECE(^(0),"^",2)
- +2 IF 'PSDNL!('PSDTYPE)
- KILL PSDNL,PSDTYPE
- QUIT
- +3 KILL ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
- +4 QUIT
- SAFL ;set 'AF' (for loc) on field 3 in 58.81
- +1 SET PSDATT=$PIECE(^PSD(58.81,DA,0),"^",4)
- SET PSDTYPE=$PIECE(^(0),"^",2)
- +2 IF 'PSDATT!('PSDTYPE)
- KILL PSDATT,PSDTYPE
- QUIT
- +3 SET ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)=""
- KILL PSDATT,PSDTYPE
- +4 QUIT
- KAFL ;kill 'AF' (for loc) on field 3 in 58.81
- +1 SET PSDATT=$PIECE(^PSD(58.81,DA,0),"^",4)
- SET PSDTYPE=$PIECE(^(0),"^",2)
- +2 IF 'PSDATT!('PSDTYPE)
- KILL PSDATT,PSDTYPE
- QUIT
- +3 KILL ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
- +4 QUIT
- SASITE ;set 'ASITE' x-ref on field 2 in 58.8
- +1 if $PIECE(^PSD(58.8,DA,0),"^",2)=""
- QUIT
- +2 SET PSDTYPE=$PIECE(^PSD(58.8,DA,0),"^",2)
- +3 SET ^PSD(58.8,"ASITE",X,PSDTYPE,DA)=""
- KILL PSDTYPE
- +4 QUIT
- KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
- +1 if $PIECE(^PSD(58.8,DA,0),"^",2)=""
- QUIT
- +2 SET PSDTYPE=$PIECE(^PSD(58.8,DA,0),"^",2)
- +3 KILL ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
- +4 QUIT
- SASITE1 ;set 'ASITE' x-ref on field 1
- +1 SET PSDDS=$PIECE(^PSD(58.8,DA,0),"^",3)
- IF 'PSDDS
- KILL PSDDS
- QUIT
- +2 SET ^PSD(58.8,"ASITE",PSDDS,X,DA)=""
- KILL PSDDS
- +3 QUIT
- KASITE1 ;k 'ASITE' on field 1 in 58.8
- +1 SET PSDDS=$PIECE(^PSD(58.8,DA,0),"^",3)
- IF 'PSDDS
- KILL PSDDS
- QUIT
- +2 KILL ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
- +3 QUIT
- SAFT ;set 'AF' field 1 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDATT=$PIECE(^(0),"^",4)
- +2 IF 'PSDNL!('PSDATT)
- KILL PSDNL,PSDATT
- QUIT
- +3 SET ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)=""
- KILL PSDATT,PSDNL
- +4 QUIT
- KAFT ;kill 'AF' field 1 in 58.81
- +1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
- SET PSDATT=$PIECE(^(0),"^",4)
- +2 IF 'PSDNL!('PSDATT)
- KILL PSDNL,PSDATT
- QUIT
- +3 KILL ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
- +4 QUIT