APSPDUE ; IHS/DSD/ENM - ENTER DUE'S IN DRUG FILE ; [ 09/03/97 1:30 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
;
; This routine will add DUE Criteria Names to the DUE Multiple
; of the Drug File. It will only add it to those drugs that
; do not already contain an Criteria Name of the same name.
; It is also used to delete Criteria names from the Drug File
; by calling APSPDUED
;
; Local Variables: APSPDUE array,%,I
; Global Variables: ^PSDRUG(, ^TMP("APSPDUE",$J,
; External calls: DIC,DIE,YN^DICN,APSPDUED
;----------------------------------------------------------
START ;
K ^TMP("APSPDUE",$J)
D DUE ;Select Criteria Name
D:$D(APSPDUE("NAME"))#2 ASK ;Ask whether the user wants to add or delete
I $D(APSPDUE)#2 D:APSPDUE=2 ^APSPDUED ;Delete DUE entries from multiple
I $D(APSPDUE)#2 D:APSPDUE=1 DRUG ;Select Drugs
D:$D(APSPDUE("DRUGS"))#2 ADD ;Add to DUE Multiple of Drug File
END D EOJ ;Clean up variables
Q
;
;-------------------------------------------------------------
DUE ; Do lookup of DUE Criteria name
S DIC(0)="QEMA",DIC="^APSPDUE(32.1,"
S DIC("A")="Select DUE Criteria Name : "
D ^DIC
I Y="-1" G:X=""!(X="^") DUEX G DUE
S APSPDUE("NAME")=+Y
D DISP ; Displays Drugs that are already marked as part of the study
W !
DUEX ; Exit point from DUE subroutine
K DIC,DA K:X="^" APSPDUE("NAME") K X,Y
Q
DISP ;
G:'$D(^PSDRUG("APSPCN",APSPDUE("NAME"))) DISPX
W !!,"The following drugs have been marked to be part of this study",!
S APSPDUE("CNT")=0
F APSPDUEI=0:0 S APSPDUEI=$O(^PSDRUG("APSPCN",APSPDUE("NAME"),APSPDUEI)) Q:'APSPDUEI I $D(^PSDRUG(APSPDUEI,0)) W:'APSPDUE("CNT") ! W:APSPDUE("CNT") ?45 W $P(^(0),U,1) S APSPDUE("CNT")=(APSPDUE("CNT")+1) S:APSPDUE("CNT")=2 APSPDUE("CNT")=0
W !
K APSPDUEI
DISPX Q
;
ASK ; Ask if want to delete or add
S DIR(0)="SO^1:Select Drugs to include in DUE;2:Delete DUE tags from all drugs"
S DIR("B")="1"
S DIR("?")=" "
S DIR("?",1)="If you enter a '1' you will then be prompted to select drugs to include in your DUE "
S DIR("?",2)="If you enter a '2' then all DUE tags for the selected DUE will be removed from your drug file"
D ^DIR
S:'$D(DTOUT)&('$D(DUOUT)) APSPDUE=$S(Y=1:"1",1:"2")
ASKX ; Exit point from ASK subroutine
Q
;
DRUG ; Do lookup of DRUG names
S DIC(0)="QEMA",DIC="^PSDRUG("
S DIC("A")="Select the Drug you wish to include : "
D ^DIC
I Y="-1" G:X=""!(X="^") DRUGX G DRUG
S %=2 W !,"Do you want to include all drugs beginning with this name "
D YN^DICN
I %=0 W !!,"If you enter Yes, all drugs in the drug file beginning with the first part of",!,"the drug name you selected will automatically be included.",!! G DRUG
S APSPDUE("DRUGS")=$S(%=1&($D(^PSDRUG(+Y,0))#2):$P(^(0)," ",1),1:+Y)
S:APSPDUE("DRUGS")]0 ^TMP("APSPDUE",$J,APSPDUE("DRUGS"))=""
G DRUG
DRUGX ; Exit point from DRUG subroutine
K DIC,DA K:X="^" APSPDUE("DRUGS") K Y,X
Q
;
ADD ; Add to DUR multiple in Drug File
S APSPDUE("DRUGS")=0
F I=0:0 S APSPDUE("DRUGS")=$O(^TMP("APSPDUE",$J,APSPDUE("DRUGS"))) Q:APSPDUE("DRUGS")="" D:APSPDUE("DRUGS")]"@" NAMES I "@"]APSPDUE("DRUGS") D
. S DIE="^PSDRUG(",DA=APSPDUE("DRUGS")
. S DR="9999999.11///"_"`"_APSPDUE("NAME")
. D ^DIE K DO,DA,X,Y,DIE
. W "."
W "Done"
Q
;
NAMES ; Add to DUR multiple in Drug File for Multiple Drug Entires
S APSPDUE("DFN")=""
S APSPDUE("CLASS")=APSPDUE("DRUGS")
F I=0:0 S APSPDUE("CLASS")=$O(^PSDRUG("B",APSPDUE("CLASS"))) Q:APSPDUE("CLASS")'[APSPDUE("DRUGS") S APSPDUE("DFN")=$O(^PSDRUG("B",APSPDUE("CLASS"),"")) D
. I '$D(^PSDRUG("APSPCN",APSPDUE("NAME"),APSPDUE("DFN"))),$D(^PSDRUG(APSPDUE("DFN"),0))#2 D
.. S DIE="^PSDRUG(",DR="9999999.11///"_"`"_APSPDUE("NAME")
.. S DA=APSPDUE("DFN")
.. D ^DIE K DA,DO,DR,X,Y,DIE
.. W "."
Q
;
EOJ ; Clean up local variables
K DIC,DA,X,Y,APSPDUE,^TMP("APSPDUE",$J),%,I,DIR,DTOUT,DUOUT
K APSPDUEI
Q
APSPDUE ; IHS/DSD/ENM - ENTER DUE'S IN DRUG FILE ; [ 09/03/97 1:30 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ;
+3 ; This routine will add DUE Criteria Names to the DUE Multiple
+4 ; of the Drug File. It will only add it to those drugs that
+5 ; do not already contain an Criteria Name of the same name.
+6 ; It is also used to delete Criteria names from the Drug File
+7 ; by calling APSPDUED
+8 ;
+9 ; Local Variables: APSPDUE array,%,I
+10 ; Global Variables: ^PSDRUG(, ^TMP("APSPDUE",$J,
+11 ; External calls: DIC,DIE,YN^DICN,APSPDUED
+12 ;----------------------------------------------------------
START ;
+1 KILL ^TMP("APSPDUE",$JOB)
+2 ;Select Criteria Name
DO DUE
+3 ;Ask whether the user wants to add or delete
IF $DATA(APSPDUE("NAME"))#2
DO ASK
+4 ;Delete DUE entries from multiple
IF $DATA(APSPDUE)#2
IF APSPDUE=2
DO ^APSPDUED
+5 ;Select Drugs
IF $DATA(APSPDUE)#2
IF APSPDUE=1
DO DRUG
+6 ;Add to DUE Multiple of Drug File
IF $DATA(APSPDUE("DRUGS"))#2
DO ADD
END ;Clean up variables
DO EOJ
+1 QUIT
+2 ;
+3 ;-------------------------------------------------------------
DUE ; Do lookup of DUE Criteria name
+1 SET DIC(0)="QEMA"
SET DIC="^APSPDUE(32.1,"
+2 SET DIC("A")="Select DUE Criteria Name : "
+3 DO ^DIC
+4 IF Y="-1"
IF X=""!(X="^")
GOTO DUEX
GOTO DUE
+5 SET APSPDUE("NAME")=+Y
+6 ; Displays Drugs that are already marked as part of the study
DO DISP
+7 WRITE !
DUEX ; Exit point from DUE subroutine
+1 KILL DIC,DA
IF X="^"
KILL APSPDUE("NAME")
KILL X,Y
+2 QUIT
DISP ;
+1 IF '$DATA(^PSDRUG("APSPCN",APSPDUE("NAME")))
GOTO DISPX
+2 WRITE !!,"The following drugs have been marked to be part of this study",!
+3 SET APSPDUE("CNT")=0
+4 FOR APSPDUEI=0:0
SET APSPDUEI=$ORDER(^PSDRUG("APSPCN",APSPDUE("NAME"),APSPDUEI))
IF 'APSPDUEI
QUIT
IF $DATA(^PSDRUG(APSPDUEI,0))
IF 'APSPDUE("CNT")
WRITE !
IF APSPDUE("CNT")
WRITE ?45
WRITE $PIECE(^(0),U,1)
SET APSPDUE("CNT")=(APSPDUE("CNT")+1)
IF APSPDUE("CNT")=2
SET APSPDUE("CNT")=0
+5 WRITE !
+6 KILL APSPDUEI
DISPX QUIT
+1 ;
ASK ; Ask if want to delete or add
+1 SET DIR(0)="SO^1:Select Drugs to include in DUE;2:Delete DUE tags from all drugs"
+2 SET DIR("B")="1"
+3 SET DIR("?")=" "
+4 SET DIR("?",1)="If you enter a '1' you will then be prompted to select drugs to include in your DUE "
+5 SET DIR("?",2)="If you enter a '2' then all DUE tags for the selected DUE will be removed from your drug file"
+6 DO ^DIR
+7 IF '$DATA(DTOUT)&('$DATA(DUOUT))
SET APSPDUE=$SELECT(Y=1:"1",1:"2")
ASKX ; Exit point from ASK subroutine
+1 QUIT
+2 ;
DRUG ; Do lookup of DRUG names
+1 SET DIC(0)="QEMA"
SET DIC="^PSDRUG("
+2 SET DIC("A")="Select the Drug you wish to include : "
+3 DO ^DIC
+4 IF Y="-1"
IF X=""!(X="^")
GOTO DRUGX
GOTO DRUG
+5 SET %=2
WRITE !,"Do you want to include all drugs beginning with this name "
+6 DO YN^DICN
+7 IF %=0
WRITE !!,"If you enter Yes, all drugs in the drug file beginning with the first part of",!,"the drug name you selected will automatically be included.",!!
GOTO DRUG
+8 SET APSPDUE("DRUGS")=$SELECT(%=1&($DATA(^PSDRUG(+Y,0))#2):$PIECE(^(0)," ",1),1:+Y)
+9 IF APSPDUE("DRUGS")]0
SET ^TMP("APSPDUE",$JOB,APSPDUE("DRUGS"))=""
+10 GOTO DRUG
DRUGX ; Exit point from DRUG subroutine
+1 KILL DIC,DA
IF X="^"
KILL APSPDUE("DRUGS")
KILL Y,X
+2 QUIT
+3 ;
ADD ; Add to DUR multiple in Drug File
+1 SET APSPDUE("DRUGS")=0
+2 FOR I=0:0
SET APSPDUE("DRUGS")=$ORDER(^TMP("APSPDUE",$JOB,APSPDUE("DRUGS")))
IF APSPDUE("DRUGS")=""
QUIT
IF APSPDUE("DRUGS")]"@"
DO NAMES
IF "@"]APSPDUE("DRUGS")
Begin DoDot:1
+3 SET DIE="^PSDRUG("
SET DA=APSPDUE("DRUGS")
+4 SET DR="9999999.11///"_"`"_APSPDUE("NAME")
+5 DO ^DIE
KILL DO,DA,X,Y,DIE
+6 WRITE "."
End DoDot:1
+7 WRITE "Done"
+8 QUIT
+9 ;
NAMES ; Add to DUR multiple in Drug File for Multiple Drug Entires
+1 SET APSPDUE("DFN")=""
+2 SET APSPDUE("CLASS")=APSPDUE("DRUGS")
+3 FOR I=0:0
SET APSPDUE("CLASS")=$ORDER(^PSDRUG("B",APSPDUE("CLASS")))
IF APSPDUE("CLASS")'[APSPDUE("DRUGS")
QUIT
SET APSPDUE("DFN")=$ORDER(^PSDRUG("B",APSPDUE("CLASS"),""))
Begin DoDot:1
+4 IF '$DATA(^PSDRUG("APSPCN",APSPDUE("NAME"),APSPDUE("DFN")))
IF $DATA(^PSDRUG(APSPDUE("DFN"),0))#2
Begin DoDot:2
+5 SET DIE="^PSDRUG("
SET DR="9999999.11///"_"`"_APSPDUE("NAME")
+6 SET DA=APSPDUE("DFN")
+7 DO ^DIE
KILL DA,DO,DR,X,Y,DIE
+8 WRITE "."
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
EOJ ; Clean up local variables
+1 KILL DIC,DA,X,Y,APSPDUE,^TMP("APSPDUE",$JOB),%,I,DIR,DTOUT,DUOUT
+2 KILL APSPDUEI
+3 QUIT
