APSQFAS4.m

APSQFAS4 ;IHS/DSD/JCM - ORDER ENTRY FAST DRUG SELECTION  

 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001

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

START ;

 S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0

 D SELECT ; Select Drug

 I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE

 G:PSONEW("DFLG")!(PSODRG("QFLG")) END

 D SET ; Set various drug information

 D POST I PSORX("DFLG") S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action

END D EOJ

 Q

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

 ;

SELECT ;

 K DIC,X,Y,PSODRUG("TRADE NAME")

 I $G(PSODRUG("IEN"))]"" S DIC("B")=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")

 ;S DIC="^PSDRUG(",DIC(0)="MQEAZO",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC

 S Y=$G(APSQF(2,"I")),Y(0)=^PSDRUG(Y,0) ;IHS/OKCAO/POC FAST OPTION

 S:Y>0 X=$P(^PSDRUG(Y,0),U,1) ;IHS/OKCAO/POC FAST OPTION

 W !,X ;FAST OPTION

 ;IHS/DSD/ENM 01/31/97 NEXT LI COPIED MODIFIED/DISABLED

 ;S DIC="^PSDRUG(",DIC(0)="MQEAZ",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC

 I X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX

 I $D(DTOUT)!($D(DUOUT)) S PSONEW("DFLG")=1 G SELECTX

 ;I Y<0 G SELECT

 S:Y<1 PSODRG("QFLG")=1 ;IHS/OKCAO/POC FAST OPTION

 S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1

 K PSOY S PSOY=Y,PSOY(0)=Y(0)

 ;D ^APSPMAN ;IHS/DSD/ENM MANUFACTURER CALL 1-6-95 8/18/2000 IHS/OKCAO/POC

 I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE

SELECTX K X,Y,DTOUT,DUOUT

 Q

 ;

TRADE ;

 K DIR,DIC,DA,X,Y

 S DIR(0)="52,6.5" D ^DIR K DIR,DIC

 I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX

 S PSODRUG("TRADE NAME")=Y

TRADEX K DIRUT,DTOUT,DUOUT,X,Y

 Q

 ;

SET ;

 S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)

 S PSODRUG("NAME")=$P(PSOY(0),"^")

 S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)

 S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)

 S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)

 S PSODRUG("SIG")=$P(PSOY(0),"^",5)

 S PSODRUG("NDC")=$P($G(^PSDRUG(+PSOY,2)),"^",4)

 S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))

 G:$G(^PSDRUG(+PSOY,660))']"" SETX

 S PSOX1=$G(^PSDRUG(+PSOY,660))

 S PSODRUG("COST")=$P($G(PSOX1),"^",6)

 S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)

 ;S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)

 S PSODRUG("AWP")=$P($G(^PSDRUG(+PSOY,999999931)),"^",2) ;AWP PRICE IHS/OKCAO/POC 8/18/2000

 ;MORE CHANGES IHS/OKCAO/POC 8/18/2000

 ;S DIC="^PSDRUG(",DR="9999999.24:9999999.26",DA=PSODRUG("IEN"),DIQ="APSQ(""DIQ1"",",DIQ(0)="I"

 S DIC="^PSDRUG(",DR="9999999.25:9999999.26",DA=PSODRUG("IEN"),DIQ="APSQ(""DIQ1"",",DIQ(0)="I"

 D EN^DIQ1

 ;S PSONEW("MANUFACTURER")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.24,""I"")")

 S PSONEW("LOT #")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.25,""I"")")

 S PSONEW("EXPIRATION DATE")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.26,""I"")")

 I $G(PSONEW("EXPIRATION DATE"))["T+" S X=PSONEW("EXPIRATION DATE"),%DT="" D ^%DT S:Y'=-1 PSONEW("EXPIRATION DATE")=Y ;IHS/OKCAO/POC 1/9/2001 IN CASE FIELD HAS T+ CHANGE TO A FILEMAN DATE

 ;CRAP I NEED THE EXTERNAL FOR THE FAST OPTION

 S DIC="^PSDRUG(",DR="9999999.24",DA=PSODRUG("IEN"),DIQ="APSQ(""DIQ1"",",DIQ(0)="E"

 D EN^DIQ1

 S PSONEW("MANUFACTURER")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.24,""E"")")

 ;END OF CHANGES IHS/OKCAO/POC 8/18/2000

SETX K PSOX1,PSOY

 K APSQ("DIQ1") ;8/18/2000 IHS/OKCAO/POC

 Q

 ;

POST ;

 S PSORX("DFLG")=0

 ;I $G(DUZ("AG"))="I" D ^PSODRG99 ; IHS specific call

 D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop

 S X="APSQDRDU" X ^%ZOSF("TEST") I $T D ^APSQDRDU ;IHS/DSD/ENM/POC 05/11/98 DUP OUTSIDE RX CK

 Q:$G(PSORX("DFLG"))

 ;D ^PSODGDGI D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX

 D ^PSODGDGI G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 MULTI-INTERVENS

 S X="APSQDGDG" X ^%ZOSF("TEST") I $T D ^APSQDGDG G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK CHANGED DGLG TO DFLG IHS/OKCAO/POC 5/26/98

 S X="APSQALLE" X ^%ZOSF("TEST") I $T K PSORX("INTERVENE") ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK

 S X="APSQALLE" X ^%ZOSF("TEST") I $T D EN^APSQALLE D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK CHANGED DGLG TO DFLG IHS/OKCAO/POC 5/26/98

 ;

 ;IHS/DSD/ENM NEXT LINE ROUTINE IS UNDER DEVELOPMENT

 ;D EN^APSPALG D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/DSD/POC/ENM ADDED FOR ALLERGY CHECK

 D POSTX ;IHS/OKCAO/POC 9/28/98

 S X="APSQCK" X ^%ZOSF("TEST") I $T D RX^APSQCK D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/OKCAO/POC 9/28/98

 D POSTX ;IHS/OKCAO/POC 9/28/98

 D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX

 ; Do ^allergy check

 ;D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop

 ; ^Do any other action revolving around the drug selection

POSTX ;

 K PSORX("INTERVENE")

 Q

 ;

EOJ ;

 K PSODRG

 Q

 ;

CLOZ ;

 S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0

 S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN

 X ^%ZOSF("TEST") I  D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1

 K P(5),ANQRTN,ANQX,X

 Q

APSQFAS4  ;IHS/DSD/JCM - ORDER ENTRY FAST DRUG SELECTION  

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001

 +2       ;----------------------------------------------------------

START     ;

 +1        SET (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0

 +2       ; Select Drug

           DO SELECT

 +3        IF $GET(PSORX("EDIT"))]""

               IF 'PSONEW("FIELD")

                   DO TRADE

 +4        IF PSONEW("DFLG")!(PSODRG("QFLG"))

               GOTO END

 +5       ; Set various drug information

           DO SET

 +6       ; Do any post selection action

           DO POST

           IF PSORX("DFLG")

               SET PSONEW("DFLG")=1

               IF '$GET(PSORX("EDIT"))

                   KILL PSORX("DFLG")

END        DO EOJ

 +1        QUIT 

 +2       ;------------------------------------------------------------

 +3       ;

SELECT    ;

 +1        KILL DIC,X,Y,PSODRUG("TRADE NAME")

 +2        IF $GET(PSODRUG("IEN"))]""

               SET DIC("B")=PSODRUG("NAME")

               SET PSONEW("OLD VAL")=PSODRUG("IEN")

 +3       ;S DIC="^PSDRUG(",DIC(0)="MQEAZO",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC

 +4       ;IHS/OKCAO/POC FAST OPTION

           SET Y=$GET(APSQF(2,"I"))

           SET Y(0)=^PSDRUG(Y,0)

 +5       ;IHS/OKCAO/POC FAST OPTION

           IF Y>0

               SET X=$PIECE(^PSDRUG(Y,0),U,1)

 +6       ;FAST OPTION

           WRITE !,X

 +7       ;IHS/DSD/ENM 01/31/97 NEXT LI COPIED MODIFIED/DISABLED

 +8       ;S DIC="^PSDRUG(",DIC(0)="MQEAZ",DIC("A")="DRUG: ",DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1)" D ^DIC K DIC

 +9        IF X[U

               IF $LENGTH(X)>1

                   SET PSODIR("FLD")=PSONEW("FLD")

                   DO JUMP^PSODIR1

                   IF $GET(PSODIR("FIELD"))

                       SET PSONEW("FIELD")=PSODIR("FIELD")

                   KILL PSODIR

                   SET PSODRG("QFLG")=1

                   GOTO SELECTX

 +10       IF $DATA(DTOUT)!($DATA(DUOUT))

               SET PSONEW("DFLG")=1

               GOTO SELECTX

 +11      ;I Y<0 G SELECT

 +12      ;IHS/OKCAO/POC FAST OPTION

           IF Y<1

               SET PSODRG("QFLG")=1

 +13       IF $GET(PSONEW("OLD VAL"))=+Y

               SET PSODRG("QFLG")=1

 +14       KILL PSOY

           SET PSOY=Y

           SET PSOY(0)=Y(0)

 +15      ;D ^APSPMAN ;IHS/DSD/ENM MANUFACTURER CALL 1-6-95 8/18/2000 IHS/OKCAO/POC

 +16       IF $PIECE(PSOY(0),"^")="OTHER DRUG"!($PIECE(PSOY(0),"^")="OUTSIDE DRUG")

               DO TRADE

SELECTX    KILL X,Y,DTOUT,DUOUT

 +1        QUIT 

 +2       ;

TRADE     ;

 +1        KILL DIR,DIC,DA,X,Y

 +2        SET DIR(0)="52,6.5"

           DO ^DIR

           KILL DIR,DIC

 +3        IF $DATA(DIRUT)

               IF $DATA(DUOUT)!$DATA(DTOUT)&('$DATA(PSORX("EDIT")))

                   SET PSONEW("DFLG")=1

               GOTO TRADEX

 +4        SET PSODRUG("TRADE NAME")=Y

TRADEX     KILL DIRUT,DTOUT,DUOUT,X,Y

 +1        QUIT 

 +2       ;

SET       ;

 +1        SET PSODRUG("IEN")=+PSOY

           SET PSODRUG("VA CLASS")=$PIECE(PSOY(0),"^",2)

 +2        SET PSODRUG("NAME")=$PIECE(PSOY(0),"^")

 +3        SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)

 +4        SET PSODRUG("MAXDOSE")=$PIECE(PSOY(0),"^",4)

           SET PSODRUG("DEA")=$PIECE(PSOY(0),"^",3)

 +5        SET PSODRUG("CLN")=$SELECT($DATA(^PSDRUG(+PSOY,"ND")):+$PIECE(^("ND"),"^",6),1:0)

 +6        SET PSODRUG("SIG")=$PIECE(PSOY(0),"^",5)

 +7        SET PSODRUG("NDC")=$PIECE($GET(^PSDRUG(+PSOY,2)),"^",4)

 +8        SET PSODRUG("STKLVL")=$GET(^PSDRUG(+PSOY,660.1))

 +9        IF $GET(^PSDRUG(+PSOY,660))']""

               GOTO SETX

 +10       SET PSOX1=$GET(^PSDRUG(+PSOY,660))

 +11       SET PSODRUG("COST")=$PIECE($GET(PSOX1),"^",6)

 +12       SET PSODRUG("UNIT")=$PIECE($GET(PSOX1),"^",8)

 +13      ;S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)

 +14      ;AWP PRICE IHS/OKCAO/POC 8/18/2000

           SET PSODRUG("AWP")=$PIECE($GET(^PSDRUG(+PSOY,999999931)),"^",2)

 +15      ;MORE CHANGES IHS/OKCAO/POC 8/18/2000

 +16      ;S DIC="^PSDRUG(",DR="9999999.24:9999999.26",DA=PSODRUG("IEN"),DIQ="APSQ(""DIQ1"",",DIQ(0)="I"

 +17       SET DIC="^PSDRUG("

           SET DR="9999999.25:9999999.26"

           SET DA=PSODRUG("IEN")

           SET DIQ="APSQ(""DIQ1"","

           SET DIQ(0)="I"

 +18       DO EN^DIQ1

 +19      ;S PSONEW("MANUFACTURER")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.24,""I"")")

 +20       SET PSONEW("LOT #")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.25,""I"")")

 +21       SET PSONEW("EXPIRATION DATE")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.26,""I"")")

 +22      ;IHS/OKCAO/POC 1/9/2001 IN CASE FIELD HAS T+ CHANGE TO A FILEMAN DATE

           IF $GET(PSONEW("EXPIRATION DATE"))["T+"

               SET X=PSONEW("EXPIRATION DATE")

               SET %DT=""

               DO ^%DT

               IF Y'=-1

                   SET PSONEW("EXPIRATION DATE")=Y

 +23      ;CRAP I NEED THE EXTERNAL FOR THE FAST OPTION

 +24       SET DIC="^PSDRUG("

           SET DR="9999999.24"

           SET DA=PSODRUG("IEN")

           SET DIQ="APSQ(""DIQ1"","

           SET DIQ(0)="E"

 +25       DO EN^DIQ1

 +26       SET PSONEW("MANUFACTURER")=@("APSQ(""DIQ1"",50,"_PSODRUG("IEN")_",9999999.24,""E"")")

 +27      ;END OF CHANGES IHS/OKCAO/POC 8/18/2000

SETX       KILL PSOX1,PSOY

 +1       ;8/18/2000 IHS/OKCAO/POC

           KILL APSQ("DIQ1")

 +2        QUIT 

 +3       ;

POST      ;

 +1        SET PSORX("DFLG")=0

 +2       ;I $G(DUZ("AG"))="I" D ^PSODRG99 ; IHS specific call

 +3       ; Set PSORX("DFLG")=1 if process to stop

           DO ^PSODRDUP

 +4       ;IHS/DSD/ENM/POC 05/11/98 DUP OUTSIDE RX CK

           SET X="APSQDRDU"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO ^APSQDRDU

 +5        IF $GET(PSORX("DFLG"))

               QUIT 

 +6       ;D ^PSODGDGI D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX

 +7       ;IHS/DSD/ENM/POC 05/11/98 MULTI-INTERVENS

           DO ^PSODGDGI

           IF PSORX("DFLG")

               GOTO POSTX

 +8       ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK CHANGED DGLG TO DFLG IHS/OKCAO/POC 5/26/98

           SET X="APSQDGDG"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO ^APSQDGDG

               IF PSORX("DFLG")

                   GOTO POSTX

 +9       ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK

           SET X="APSQALLE"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               KILL PSORX("INTERVENE")

 +10      ;IHS/DSD/ENM/POC 05/11/98 OUTSIDE RX CK CHANGED DGLG TO DFLG IHS/OKCAO/POC 5/26/98

           SET X="APSQALLE"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO EN^APSQALLE

               IF $GET(PSORX("INTERVENE"))]""

                   DO ^PSORXI

               IF PSORX("DFLG")

                   GOTO POSTX

 +11      ;

 +12      ;IHS/DSD/ENM NEXT LINE ROUTINE IS UNDER DEVELOPMENT

 +13      ;D EN^APSPALG D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/DSD/POC/ENM ADDED FOR ALLERGY CHECK

 +14      ;IHS/OKCAO/POC 9/28/98

           DO POSTX

 +15      ;IHS/OKCAO/POC 9/28/98

           SET X="APSQCK"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO RX^APSQCK

               IF $GET(PSORX("INTERVENE"))]""

                   DO ^PSORXI

               IF PSORX("DFLG")

                   GOTO POSTX

 +16      ;IHS/OKCAO/POC 9/28/98

           DO POSTX

 +17       IF $PIECE($GET(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]""

               DO CLOZ

           IF PSORX("DFLG")

               GOTO POSTX

 +18      ; Do ^allergy check

 +19      ;D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop

 +20      ; ^Do any other action revolving around the drug selection

POSTX     ;

 +1        KILL PSORX("INTERVENE")

 +2        QUIT 

 +3       ;

EOJ       ;

 +1        KILL PSODRG

 +2        QUIT 

 +3       ;

CLOZ      ;

 +1        SET ANQRTN=$PIECE(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^")

           SET ANQX=0

 +2        SET P(5)=PSODRUG("IEN")

           SET DFN=PSODFN

           SET X=ANQRTN

 +3        XECUTE ^%ZOSF("TEST")

          IF $TEST

               DO @("^"_ANQRTN)

               IF $GET(ANQX)

                   SET PSORX("DFLG")=1

 +4        KILL P(5),ANQRTN,ANQX,X

 +5        QUIT