Routine: APSPDUE

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

 ;-------------------------------------------------------------

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

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

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

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"

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 "."

EOJ ; Clean up local variables

 K DIC,DA,X,Y,APSPDUE,^TMP("APSPDUE",$J),%,I,DIR,DTOUT,DUOUT

 K APSPDUEI

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

APSPDUE.m