APSPDIR.m

APSPDIR ;IHS/CIA/PLS - ASKS DATA FOR RX ORDER ENTRY ;25-Apr-2016 14:22;DU

 ;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1006,1008,1013,1015,1017,1018,1021**;Sep 23, 2004;Build 14

 ; This routine contains additional prompts for input of IHS specific data.

 ; Original Entry points courtesy of Patrick Cox.

 ; Patch 1006 adds new TRPDCLS entry point.

 ; Patch 1008 adds support for SUBSTITUTION and CASH DUE prompts and check for SANS default Chronic Med prompt

 ; Patch 1015 added PSODRUG("DAW") at SUBS+3

 ; Patch 1017 adds support for Discharge Medication

BST(PSODIR) ; EP - Bill Status

 N DIR,DIC,X,Y,B

 S DIR(0)="52,9999999.07"

 S:$G(PSOBILST)]"" DIR("B")=PSOBILST

 S B=$$GET1^DIQ(52,+$G(PSODIR("IRXN")),9999999.07,"I")

 S:$L(B) DIR("B")=B

 S:$G(PSODIR("BST"))]"" DIR("B")=PSODIR("BST")

 S:$L(DIR("B")) DIR("B")=$$EXTERNAL^DILFD(52,9999999.07,,DIR("B"))

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") BSTX

 S PSODIR("BST")=Y

BSTX Q

 ;

MANUF(PSODIR) ; EP - Select and stuff manufacturer

 Q:'$G(PSODRUG("IEN"))

 N DIR,DIC,Y,DIE,DA,DR

 S DIC=55.95,DIC(0)="AEMQ"

 S DIC("A")="MANUFACTURER: "

 S:$G(PSODRUG("MANUFACTURER"))]"" DIC("B")=PSODRUG("MANUFACTURER")

 S:$G(PSODIR("MANUFACTURER"))]"" DIC("B")=PSODIR("MANUFACTURER")

 D ^DIC

 S PSODIR("FIELD")=0 D DIRS^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") MANUFX

 I Y>0 D

 .S PSODIR("MANUFACTURER")=$P(Y,U,2)

 .S PSODIR("MANUFACTURERIEN")=+Y

 .S DIE="^PSDRUG("

 .S DA=PSODRUG("IEN")

 .S DR="9999999.24///^S X=""`""_PSODIR(""MANUFACTURERIEN"")"

 .D ^DIE

MANUFX Q

 ;

LOT(PSODIR) ; EP - Collect and stuff Lot Number

 Q:'$G(PSODRUG("IEN"))

 N DIR,DIC,Y,DIE,DA,DR

 S DIR(0)="52,24"

 S:$G(PSODRUG("LOT #"))]"" DIR("B")=PSODRUG("LOT #")

 S:$G(PSODIR("LOT #"))]"" DIR("B")=PSODIR("LOT #")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") LOTX

 S PSODIR("LOT #")=Y

 I Y>0 D

 . S DIE="^PSDRUG("

 . S DA=PSODRUG("IEN")

 . S DR="9999999.25///^S X=PSODIR(""LOT #"")"

 . D ^DIE

LOTX Q

 ;

EXPDATE(PSODIR) ; EP - Prompt and stuff Expiration Date

 Q:'$G(PSODRUG("IEN"))

 N DIR,DIC,Y,DIE,DA,DR

 S DIR(0)="DO^DT::EX"

 S DIR("A")="EXPIRATION DATE"

 I $G(PSODRUG("EXPIRATION DATE"))]"" D

 .I (DT<PSODRUG("EXPIRATION DATE"))!($E(PSODRUG("EXPIRATION DATE"),1,2)="T+") D

 ..S DIR("B")=$$FMTE^XLFDT(PSODRUG("EXPIRATION DATE"))

 I $G(PSODIR("EXPIRATION DATE"))]"" D

 .S DIR("B")=$$FMTE^XLFDT(PSODIR("EXPIRATION DATE"))

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") EXPDATEX

 S PSODIR("EXPIRATION DATE")=Y

 I Y>0 D

 .S DIE="^PSDRUG("

 .S DA=PSODRUG("IEN")

 .S DR="9999999.26///^S X=PSODIR(""EXPIRATION DATE"")"

 .D ^DIE

 E  S PSODIR("EXPIRATION DATE")=""

EXPDATEX Q

 ;

NDC(PSODIR) ; EP - Prompt for NDC value

 N DIR,DIC,Y,DA

 S DIR(0)="52,27"

 S DIR("A")="NDC "

 S:$G(PSODRUG("NDC"))]"" DIR("B")=PSODRUG("NDC")

 S:$G(PSODIR("NDC"))]"" DIR("B")=PSODIR("NDC")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") NDCX

 S PSODIR("NDC")=Y

NDCX Q

 ;

AWP(PSODIR) ; EP - Prompt for AWP value

 N DIR,DIC,NDC,Y,DA

 S DIR(0)="52,9999999.06"

 S DIR("A")="BENCHMARK PRICE "

 ;IF NDC NOT ASKED THEN NO VALUE FOR PSODIR("NDC") BUT GOT PSODRUG("NDC" )

 ;WILL NEED TO PASS THE FILLDATE TO APSQDAWP AND ASK FOR FILL DATE BEFOR

 ;E ASKING ABOUT AWP FOR MULTIPLE AWPS IHS/OKCAO/POC 7/3/2001

 S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$$GET1^DIQ(52,+$G(PSODIR("IRXN")),6,"I")

 S NDC=$G(PSODIR("NDC"))

 I '$L(NDC) D

 .S NDC=$$NDCVAL^APSPFUNC(+$G(PSODIR("IRXN")))

 .S:'$L(NDC) NDC=$$GET1^DIQ(50,PSODRUG("IEN"),31,"I")

 S DIR("B")=$$AWP^APSQDAWP(NDC,PSODRUG("IEN"),.TALK)

 ;S DIR("B")=$$AWP^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:+$G(PSODRUG("NDC"))),+$G(PSODRUG("IEN")),.TALK)

 ;S DIR("B")=$$AWP^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK,PSODIR("FILL DATE"))  ;FOR MULTIPLE AWPS IHS/OKCAO /POC 7/3/2001

 ;SOMEOTHER DIR("B" FROM REFILL?

 D MSG^DIALOG("WM","",75,5,"TALK")  ;IHS/OKCAO/POC 2/16/2001

 S:$G(PSODIR("AWP"))]"" DIR("B")=PSODIR("AWP")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") AWPX

 S PSODIR("AWP")=Y

AWPX Q

 ;

COST(PSODIR) ; EP - Prompt for Unit Price of Drug

 N DIR,DIC,Y,NDC,DA

 S DIR(0)="52,17"

 S DIR("A")="UNIT PRICE OF DRUG"

 S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$$GET1^DIQ(52,+$G(PSODIR("IRXN")),6,"I")

 S NDC=$G(PSODIR("NDC"))

 I '$L(NDC) D

 .S NDC=$$NDCVAL^APSPFUNC(+$G(PSODIR("IRXN")))

 .S:'$L(NDC) NDC=$$GET1^DIQ(50,PSODRUG("IEN"),31,"I")

 ;S DIR("B")=$$COST^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK)

 S DIR("B")=$$COST^APSQDAWP(NDC,PSODRUG("IEN"),.TALK)

 D MSG^DIALOG("WM","",75,5,"TALK")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") NCOST

 S PSODIR("COST")=Y

NCOST Q

 ;

HOLDER(PSODIR) ; EP - Prompt for holder

 N DIR,DIC,Y

 S DIR(0)="FAOU^1:10"

 S DIR("A")="JUMP TO FIELD//"

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") HOLDERX

 S PSODIR("HOLDER")=Y

HOLDERX Q

 ;

CM(PSODIR) ; EP - Chronic Med Enter/Edit

 N DIR,DIC,Y,DA

 S DIR(0)="52,9999999.02"

 ;IHS/MSC/PLS - 12/05/2008 - Added check for sans default

 ;S DIR("B")=$S($L($G(PSODIR("CM"))):$$EXTERNAL^DILFD(52,9999999.02,,PSODIR("CM")),APSPCMP>1:"YES",1:"NO")

 S DIR("B")=$S($L($G(PSODIR("CM"))):$$EXTERNAL^DILFD(52,9999999.02,,PSODIR("CM")),APSPCMP=2:"YES",APSPCMP=1:"NO",1:"")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") CMX

 S PSODIR("CM")=Y,APSP("CM")=Y

CMX Q

 ;

 ;

INSURER(PSODIR) ; EP - Prompt for insurer info

 ;PSODIR("INSURER") - blnk first time - pntr to ABSP(9002313.511

 ;PSODIR("DUR") = blnk first time - pntr to ABSP(9002313.473

 N DIR,DIC,Y

 S DIR(0)="YA",DIR("A")="WANT TO ADD/EDIT INSURER INFO// "

 S DIR("B")="NO"

 D ^DIR

 I X[U,$L(X)>1 D JUMP^PSODIR1 Q

 I $D(DUOUT)!($D(DTOUT)) S PSODIR("DFLG")=1 G INSURERX

 I Y'=1 S PSODIR("FIELD")=0 Q

 ;D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") INSURERX

 ; NOTE APSQDUR is set in APSQBRES (DUR pointer)

 ;SHOULD NOT BE ANY VALUE TO START WITH HERE BUT IF EDIT WILL SAVE PSODIR("INSURERS") IN APSQDUR

 S PSODIR("INSURER")=$$OVERRIDE^APSQBRES($G(PSODIR("INSURER")),$G(PSODIR("DUR")))

 S PSODIR("DUR")=APSQDUR  ; set in APSQBRES- DUR pntr

INSURERX Q

 ;

TRIP(PSODIR) ; EP - Prompt for Triplicate Number for Schedule II drugs

 Q:'$$TRPDCLS($G(PSOTRIP),$G(PSODRUG("DEA")))  ; Check triplicate drug class  ;IHS/MSC/PLS - 08/18/07

 N DIR,DIC,Y,DA

 S DIR(0)="52,9999999.14",X=""

 S:$G(PSODIR("TRIP"))]"" DIR("B")=PSODIR("TRIP")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") TRIPX

 I $L(X)>0 S PSODIR("TRIP")=X

 E  K PSODIR("TRIP")

TRIPX Q

 ; IHS/MSC/PLS - 08/18/07 - New API for patch 1006

 ; Return boolean flag indicating a match for triplicate to drug class for prescription

TRPDCLS(PARAM,DCLS) ;EP

 Q $S('$G(PARAM):0,PARAM=1&("2"[+DCLS):1,PARAM=2&("2345"[+DCLS):1,PARAM=3:1,1:0)

 ;

FILLDT(PSODIR) ; EP - Prompt for Fill Date

 N DIR,DIC,Y

 S:'$G(PSONEW("DAYS SUPPLY")) PSONEW("DAYS SUPPLY")=30,PSONEW("# OF REFILLS")=1

 S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")

 S X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1

 S X1=$S($G(PSOID):PSOID,1:DT)

 S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSODIR("CS")):184,1:366)

 I X2<30 D

 . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30

 . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5

 D C^%DTC S PSOFDMX=$P(X,".") I DT>X S Y=$S($G(PSOID):PSOID,1:PSORX("ISSUE DATE")) X ^DD("DD") S DIR("B")=Y

 S DIR(0)="D^"_$S($G(PSOID):PSOID,+$G(PSODIR("ISSUE DATE")):PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:":"_PSOFDMX_":EX")

 S Y=PSOFDMX X ^DD("DD")

 S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"

 S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE or AFTER the Expiration Date "

 S DIR("?")=Y_".  Both the month and date are required."

 D DIR^PSODIR2 G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX

 S (APSEFDT,APSEDT)=Y

 S PSODIR("FILL DATE")=Y\1

 S PSORX("FILL DATE")=$$FMTE^XLFDT(Y)

FILLDTX Q

 ;

PTSTAT(PSODIR) ;

PTSTATEN N DIC,DR,DIE,Y S PSODIR("FIELD")=0

 S:$G(PSORX("PATIENT STATUS"))]"" DIC("B")=PSORX("PATIENT STATUS")

 S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")

 S DIC("A")="PATIENT STATUS: "

 S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC

 I X[U,$L(X)>1 D JUMP^PSODIR1 G PTSTATX

 I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX

 I Y=-1 W *7," Required" G PTSTATEN

 S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y

 S (PSODIR("PTST NODE"),PSORX("PTST NODE"))=Y(0)

PTSTATX K DTOUT,DUOUT,Y,DA

 Q

 ; Prompts for Substitution selection

 ; IHS/MSC/PLS - 03/13/08

SUBS(PSODIR) ; EP - Substitution Enter/Edit

 N DIR,DIC,Y,DA

 S DIR(0)="52,9999999.25"

 ;IHS/MSC/PLS - 03/05/2013

 ;S DIR("B")=$S($L($G(PSODIR("DAW"))):$$EXTERNAL^DILFD(52,9999999.25,,PSODIR("DAW")),1:"")

 S DIR("B")=$S($L($G(PSODIR("DAW"))):$$EXTERNAL^DILFD(52,9999999.25,,PSODIR("DAW")),$G(PSODRUG("DAW")):PSODRUG("DAW"),1:"")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") SUBSX

 S PSODIR("DAW")=Y

SUBSX Q

 ; Prompts for Cash Due

CASHDUE(PSODIR) ; EP - Cash Due Enter/Edit

 N DIR,DIC,Y,DA

 S DIR(0)="52,9999999.26"

 S DIR("B")=$S($L($G(PSODIR("CASH DUE"))):$$EXTERNAL^DILFD(52,9999999.26,,PSODIR("CASH DUE")),1:"")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") CASHDUEX

 S PSODIR("CASH DUE")=Y

CASHDUEX Q

 ; Prompts for Discharge Medication

 ; IHS/MSC/PLS - 06/05/13

DSCMED(PSODIR) ; EP - Discharge Medication Enter/Edit

 Q:$$GET1^DIQ(9009033,PSOSITE,408,"I")  ;P1018

 N DIR,DIC,Y,DA,OVAL,CFRM,DVAL

 S CFRM(1)="This field should be marked YES for all discharge medications"

 S CFRM(2)="from In-House Inpatient Unit or In-House Emergency Department."

 S CFRM="Are you sure you want to edit"

 S OVAL=$G(PSODIR("DSCMED"))

 S DIR(0)="52,9999999.28"

 S DIR("A")="DISCHARGE MEDICATION (In-House Inpatient/ER only)"

 S DIR("B")=$S($L($G(PSODIR("DSCMED"))):$$EXTERNAL^DILFD(52,9999999.28,,PSODIR("DSCMED")),$$INP^SDAM2(PSODFN,DT)="I":"Yes",1:"")

 S DIR("?")=" "

 S DIR("?",1)="Enter YES if this is a discharge medication from the In-House"

 S DIR("?",2)="Inpatient unit or In-House Emergency Department."

 S DIR("?",3)="This should ONLY be entered for In-House discharge medications"

 S DIR("?",4)="and not external discharge medications from other hospitals"

 S DIR("?",5)="or emergency departments."

 S DVAL=DIR("B")

 D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") DSCMEDX

 I DVAL="",Y="" D

 .S PSODIR("DSCMED")=Y

 E  I DVAL="NO",Y=0 D

 .S PSODIR("DSCMED")=Y

 E  I DVAL="YES",Y=1 D

 .S PSODIR("DSCMED")=Y

 E  I DVAL="Yes",Y=1 D

 .S PSODIR("DSCMED")=Y

 ;I OVAL="",+Y D

 ;.I $$DIRYNR^APSPUTIL(.CFRM,"NO") D

 ;..S PSODIR("DSCMED")=Y

 ;.E  S PSODIR("DSCMED")=0

 ;E  I OVAL="" S PSODIR("DSCMED")=Y

 E  D  ;I (OVAL'=+Y) D

 .I $$DIRYNR^APSPUTIL(.CFRM,"NO") D

 ..S PSODIR("DSCMED")=Y

DSCMEDX Q

 ; Allows editing of template

EDIHSFLD(DA,IT,GLOBAL) ;EP

 ;N DA,DIR,DIRUT,DIROUT,DIE,DR

 ;S DA=PSODIR("IRXN")

 S DIE=GLOBAL,DR=IT

 D ^DIE

 Q

 ; EP - Field Prompt

 ; Input - PSONEW - Array of values for prescription

 ;         SETFLD - Set "FLD" subnode array (default: No)

IHSFLDS(PSONEW,SETFLD) ;EP

 S SETFLD=$G(SETFLD,0)

 W !!

1 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=1 D TRIP^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("TRIP"))) S PSONEW("FLD",9999999.14)=PSONEW("TRIP")

2 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=2 D NDC^APSPDIR(.PSONEW)

 .K PSONEW("AWP"),PSONEW("COST")

 .I SETFLD,$L($G(PSONEW("NDC"))) S PSONEW("FLD",27)=PSONEW("NDC")

3 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=3 D AWP^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("AWP"))) S PSONEW("FLD",9999999.06)=PSONEW("AWP")

4 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=4 D COST^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("COST"))) S PSONEW("FLD",17)=PSONEW("COST")

5 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=5 D MANUF^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("MANUFACTURER"))) S PSONEW("FLD",28)=PSONEW("MANUFACTURER")

6 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=6 D EXPDATE^APSPDIR(.PSONEW)

 .I SETFLD,$D(PSONEW("EXPIRATION DATE")) S PSONEW("FLD",29)=PSONEW("EXPIRATION DATE")

7 ;S PSONEW("FLD")=7 D INSURER^APSPDIR(.PSONEW)

 ;G:PSONEW("DFLG") END

8 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=8 D CM^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("CM"))) S PSONEW("FLD",9999999.02)=PSONEW("CM")

9 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=9 D BST^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("BST"))) S PSONEW("FLD",9999999.07)=PSONEW("BST")

10 ;D  G:PSONEW("DFLG") END

 ;.S PSONEW("FLD")=10 D SUBS^APSPDIR(.PSONEW)

 ;.I SETFLD,$L($G(PSONEW("DAW"))) S PSONEW("FLD",9999999.25)=PSONEW("DAW")

11 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=11 D DSCMED^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("DSCMED"))) S PSONEW("FLD",9999999.28)=PSONEW("DSCMED")

12 D  G:PSONEW("DFLG") END

 .S PSONEW("FLD")=12 D CASHDUE^APSPDIR(.PSONEW)

 .I SETFLD,$L($G(PSONEW("CASH DUE"))) S PSONEW("FLD",9999999.26)=PSONEW("CASH DUE")

END Q

APSPDIR   ;IHS/CIA/PLS - ASKS DATA FOR RX ORDER ENTRY ;25-Apr-2016 14:22;DU

 +1       ;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1006,1008,1013,1015,1017,1018,1021**;Sep 23, 2004;Build 14

 +2       ; This routine contains additional prompts for input of IHS specific data.

 +3       ; Original Entry points courtesy of Patrick Cox.

 +4       ; Patch 1006 adds new TRPDCLS entry point.

 +5       ; Patch 1008 adds support for SUBSTITUTION and CASH DUE prompts and check for SANS default Chronic Med prompt

 +6       ; Patch 1015 added PSODRUG("DAW") at SUBS+3

 +7       ; Patch 1017 adds support for Discharge Medication

BST(PSODIR) ; EP - Bill Status

 +1        NEW DIR,DIC,X,Y,B

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

 +3        IF $GET(PSOBILST)]""

               SET DIR("B")=PSOBILST

 +4        SET B=$$GET1^DIQ(52,+$GET(PSODIR("IRXN")),9999999.07,"I")

 +5        IF $LENGTH(B)

               SET DIR("B")=B

 +6        IF $GET(PSODIR("BST"))]""

               SET DIR("B")=PSODIR("BST")

 +7        IF $LENGTH(DIR("B"))

               SET DIR("B")=$$EXTERNAL^DILFD(52,9999999.07,,DIR("B"))

 +8        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO BSTX

 +9        SET PSODIR("BST")=Y

BSTX       QUIT 

 +1       ;

MANUF(PSODIR) ; EP - Select and stuff manufacturer

 +1        IF '$GET(PSODRUG("IEN"))

               QUIT 

 +2        NEW DIR,DIC,Y,DIE,DA,DR

 +3        SET DIC=55.95

           SET DIC(0)="AEMQ"

 +4        SET DIC("A")="MANUFACTURER: "

 +5        IF $GET(PSODRUG("MANUFACTURER"))]""

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

 +6        IF $GET(PSODIR("MANUFACTURER"))]""

               SET DIC("B")=PSODIR("MANUFACTURER")

 +7        DO ^DIC

 +8        SET PSODIR("FIELD")=0

           DO DIRS^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO MANUFX

 +9        IF Y>0

               Begin DoDot:1

 +10               SET PSODIR("MANUFACTURER")=$PIECE(Y,U,2)

 +11               SET PSODIR("MANUFACTURERIEN")=+Y

 +12               SET DIE="^PSDRUG("

 +13               SET DA=PSODRUG("IEN")

 +14               SET DR="9999999.24///^S X=""`""_PSODIR(""MANUFACTURERIEN"")"

 +15               DO ^DIE

               End DoDot:1

MANUFX     QUIT 

 +1       ;

LOT(PSODIR) ; EP - Collect and stuff Lot Number

 +1        IF '$GET(PSODRUG("IEN"))

               QUIT 

 +2        NEW DIR,DIC,Y,DIE,DA,DR

 +3        SET DIR(0)="52,24"

 +4        IF $GET(PSODRUG("LOT #"))]""

               SET DIR("B")=PSODRUG("LOT #")

 +5        IF $GET(PSODIR("LOT #"))]""

               SET DIR("B")=PSODIR("LOT #")

 +6        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO LOTX

 +7        SET PSODIR("LOT #")=Y

 +8        IF Y>0

               Begin DoDot:1

 +9                SET DIE="^PSDRUG("

 +10               SET DA=PSODRUG("IEN")

 +11               SET DR="9999999.25///^S X=PSODIR(""LOT #"")"

 +12               DO ^DIE

               End DoDot:1

LOTX       QUIT 

 +1       ;

EXPDATE(PSODIR) ; EP - Prompt and stuff Expiration Date

 +1        IF '$GET(PSODRUG("IEN"))

               QUIT 

 +2        NEW DIR,DIC,Y,DIE,DA,DR

 +3        SET DIR(0)="DO^DT::EX"

 +4        SET DIR("A")="EXPIRATION DATE"

 +5        IF $GET(PSODRUG("EXPIRATION DATE"))]""

               Begin DoDot:1

 +6                IF (DT<PSODRUG("EXPIRATION DATE"))!($EXTRACT(PSODRUG("EXPIRATION DATE"),1,2)="T+")

                       Begin DoDot:2

 +7                        SET DIR("B")=$$FMTE^XLFDT(PSODRUG("EXPIRATION DATE"))

                       End DoDot:2

               End DoDot:1

 +8        IF $GET(PSODIR("EXPIRATION DATE"))]""

               Begin DoDot:1

 +9                SET DIR("B")=$$FMTE^XLFDT(PSODIR("EXPIRATION DATE"))

               End DoDot:1

 +10       DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO EXPDATEX

 +11       SET PSODIR("EXPIRATION DATE")=Y

 +12       IF Y>0

               Begin DoDot:1

 +13               SET DIE="^PSDRUG("

 +14               SET DA=PSODRUG("IEN")

 +15               SET DR="9999999.26///^S X=PSODIR(""EXPIRATION DATE"")"

 +16               DO ^DIE

               End DoDot:1

 +17      IF '$TEST

               SET PSODIR("EXPIRATION DATE")=""

EXPDATEX   QUIT 

 +1       ;

NDC(PSODIR) ; EP - Prompt for NDC value

 +1        NEW DIR,DIC,Y,DA

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

 +3        SET DIR("A")="NDC "

 +4        IF $GET(PSODRUG("NDC"))]""

               SET DIR("B")=PSODRUG("NDC")

 +5        IF $GET(PSODIR("NDC"))]""

               SET DIR("B")=PSODIR("NDC")

 +6        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO NDCX

 +7        SET PSODIR("NDC")=Y

NDCX       QUIT 

 +1       ;

AWP(PSODIR) ; EP - Prompt for AWP value

 +1        NEW DIR,DIC,NDC,Y,DA

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

 +3        SET DIR("A")="BENCHMARK PRICE "

 +4       ;IF NDC NOT ASKED THEN NO VALUE FOR PSODIR("NDC") BUT GOT PSODRUG("NDC" )

 +5       ;WILL NEED TO PASS THE FILLDATE TO APSQDAWP AND ASK FOR FILL DATE BEFOR

 +6       ;E ASKING ABOUT AWP FOR MULTIPLE AWPS IHS/OKCAO/POC 7/3/2001

 +7        IF '$GET(PSODRUG("IEN"))

               SET PSODRUG("IEN")=$$GET1^DIQ(52,+$GET(PSODIR("IRXN")),6,"I")

 +8        SET NDC=$GET(PSODIR("NDC"))

 +9        IF '$LENGTH(NDC)

               Begin DoDot:1

 +10               SET NDC=$$NDCVAL^APSPFUNC(+$GET(PSODIR("IRXN")))

 +11               IF '$LENGTH(NDC)

                       SET NDC=$$GET1^DIQ(50,PSODRUG("IEN"),31,"I")

               End DoDot:1

 +12       SET DIR("B")=$$AWP^APSQDAWP(NDC,PSODRUG("IEN"),.TALK)

 +13      ;S DIR("B")=$$AWP^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:+$G(PSODRUG("NDC"))),+$G(PSODRUG("IEN")),.TALK)

 +14      ;S DIR("B")=$$AWP^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK,PSODIR("FILL DATE"))  ;FOR MULTIPLE AWPS IHS/OKCAO /POC 7/3/2001

 +15      ;SOMEOTHER DIR("B" FROM REFILL?

 +16      ;IHS/OKCAO/POC 2/16/2001

           DO MSG^DIALOG("WM","",75,5,"TALK")

 +17       IF $GET(PSODIR("AWP"))]""

               SET DIR("B")=PSODIR("AWP")

 +18       DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO AWPX

 +19       SET PSODIR("AWP")=Y

AWPX       QUIT 

 +1       ;

COST(PSODIR) ; EP - Prompt for Unit Price of Drug

 +1        NEW DIR,DIC,Y,NDC,DA

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

 +3        SET DIR("A")="UNIT PRICE OF DRUG"

 +4        IF '$GET(PSODRUG("IEN"))

               SET PSODRUG("IEN")=$$GET1^DIQ(52,+$GET(PSODIR("IRXN")),6,"I")

 +5        SET NDC=$GET(PSODIR("NDC"))

 +6        IF '$LENGTH(NDC)

               Begin DoDot:1

 +7                SET NDC=$$NDCVAL^APSPFUNC(+$GET(PSODIR("IRXN")))

 +8                IF '$LENGTH(NDC)

                       SET NDC=$$GET1^DIQ(50,PSODRUG("IEN"),31,"I")

               End DoDot:1

 +9       ;S DIR("B")=$$COST^APSQDAWP($S($D(PSODIR("NDC")):PSODIR("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK)

 +10       SET DIR("B")=$$COST^APSQDAWP(NDC,PSODRUG("IEN"),.TALK)

 +11       DO MSG^DIALOG("WM","",75,5,"TALK")

 +12       DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO NCOST

 +13       SET PSODIR("COST")=Y

NCOST      QUIT 

 +1       ;

HOLDER(PSODIR) ; EP - Prompt for holder

 +1        NEW DIR,DIC,Y

 +2        SET DIR(0)="FAOU^1:10"

 +3        SET DIR("A")="JUMP TO FIELD//"

 +4        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO HOLDERX

 +5        SET PSODIR("HOLDER")=Y

HOLDERX    QUIT 

 +1       ;

CM(PSODIR) ; EP - Chronic Med Enter/Edit

 +1        NEW DIR,DIC,Y,DA

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

 +3       ;IHS/MSC/PLS - 12/05/2008 - Added check for sans default

 +4       ;S DIR("B")=$S($L($G(PSODIR("CM"))):$$EXTERNAL^DILFD(52,9999999.02,,PSODIR("CM")),APSPCMP>1:"YES",1:"NO")

 +5        SET DIR("B")=$SELECT($LENGTH($GET(PSODIR("CM"))):$$EXTERNAL^DILFD(52,9999999.02,,PSODIR("CM")),APSPCMP=2:"YES",APSPCMP=1:"NO",1:"")

 +6        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO CMX

 +7        SET PSODIR("CM")=Y

           SET APSP("CM")=Y

CMX        QUIT 

 +1       ;

 +2       ;

INSURER(PSODIR) ; EP - Prompt for insurer info

 +1       ;PSODIR("INSURER") - blnk first time - pntr to ABSP(9002313.511

 +2       ;PSODIR("DUR") = blnk first time - pntr to ABSP(9002313.473

 +3        NEW DIR,DIC,Y

 +4        SET DIR(0)="YA"

           SET DIR("A")="WANT TO ADD/EDIT INSURER INFO// "

 +5        SET DIR("B")="NO"

 +6        DO ^DIR

 +7        IF X[U

               IF $LENGTH(X)>1

                   DO JUMP^PSODIR1

                   QUIT 

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

               SET PSODIR("DFLG")=1

               GOTO INSURERX

 +9        IF Y'=1

               SET PSODIR("FIELD")=0

               QUIT 

 +10      ;D DIR^PSODIR1 G:PSODIR("DFLG")!PSODIR("FIELD") INSURERX

 +11      ; NOTE APSQDUR is set in APSQBRES (DUR pointer)

 +12      ;SHOULD NOT BE ANY VALUE TO START WITH HERE BUT IF EDIT WILL SAVE PSODIR("INSURERS") IN APSQDUR

 +13       SET PSODIR("INSURER")=$$OVERRIDE^APSQBRES($GET(PSODIR("INSURER")),$GET(PSODIR("DUR")))

 +14      ; set in APSQBRES- DUR pntr

           SET PSODIR("DUR")=APSQDUR

INSURERX   QUIT 

 +1       ;

TRIP(PSODIR) ; EP - Prompt for Triplicate Number for Schedule II drugs

 +1       ; Check triplicate drug class  ;IHS/MSC/PLS - 08/18/07

           IF '$$TRPDCLS($GET(PSOTRIP),$GET(PSODRUG("DEA")))

               QUIT 

 +2        NEW DIR,DIC,Y,DA

 +3        SET DIR(0)="52,9999999.14"

           SET X=""

 +4        IF $GET(PSODIR("TRIP"))]""

               SET DIR("B")=PSODIR("TRIP")

 +5        DO DIR^PSODIR1

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO TRIPX

 +6        IF $LENGTH(X)>0

               SET PSODIR("TRIP")=X

 +7       IF '$TEST

               KILL PSODIR("TRIP")

TRIPX      QUIT 

 +1       ; IHS/MSC/PLS - 08/18/07 - New API for patch 1006

 +2       ; Return boolean flag indicating a match for triplicate to drug class for prescription

TRPDCLS(PARAM,DCLS) ;EP

 +1        QUIT $SELECT('$GET(PARAM):0,PARAM=1&("2"[+DCLS):1,PARAM=2&("2345"[+DCLS):1,PARAM=3:1,1:0)

 +2       ;

FILLDT(PSODIR) ; EP - Prompt for Fill Date

 +1        NEW DIR,DIC,Y

 +2        IF '$GET(PSONEW("DAYS SUPPLY"))

               SET PSONEW("DAYS SUPPLY")=30

               SET PSONEW("# OF REFILLS")=1

 +3        SET DIR("A")="FILL DATE"

           SET DIR("B")=$SELECT($GET(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")

 +4        SET X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1

 +5        SET X1=$SELECT($GET(PSOID):PSOID,1:DT)

 +6        SET X2=$SELECT(PSONEW("DAYS SUPPLY")=X2:X2,+$GET(PSODIR("CS")):184,1:366)

 +7        IF X2<30

               Begin DoDot:1

 +8                NEW %

                   SET %=$PIECE($GET(PSORX("PATIENT STATUS")),"^")

                   SET X2=30

 +9                IF %?.N

                       SET %=$PIECE($GET(^PS(53,+%,0)),"^")

                   IF %["AUTH ABS"

                       SET X2=5

               End DoDot:1

 +10       DO C^%DTC

           SET PSOFDMX=$PIECE(X,".")

           IF DT>X

               SET Y=$SELECT($GET(PSOID):PSOID,1:PSORX("ISSUE DATE"))

               XECUTE ^DD("DD")

               SET DIR("B")=Y

 +11       SET DIR(0)="D^"_$SELECT($GET(PSOID):PSOID,+$GET(PSODIR("ISSUE DATE")):PSODIR("ISSUE DATE"),1:DT)_$SELECT($GET(DUZ("AG"))="I":":"_DT_":EX",1:":"_PSOFDMX_":EX")

 +12       SET Y=PSOFDMX

           XECUTE ^DD("DD")

 +13       SET DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"

 +14       SET DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE or AFTER the Expiration Date "

 +15       SET DIR("?")=Y_".  Both the month and date are required."

 +16       DO DIR^PSODIR2

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO FILLDTX

 +17       SET (APSEFDT,APSEDT)=Y

 +18       SET PSODIR("FILL DATE")=Y\1

 +19       SET PSORX("FILL DATE")=$$FMTE^XLFDT(Y)

FILLDTX    QUIT 

 +1       ;

PTSTAT(PSODIR) ;

PTSTATEN   NEW DIC,DR,DIE,Y

           SET PSODIR("FIELD")=0

 +1        IF $GET(PSORX("PATIENT STATUS"))]""

               SET DIC("B")=PSORX("PATIENT STATUS")

 +2        IF $GET(PSODIR("PATIENT STATUS"))]""

               SET DIC("B")=PSODIR("PATIENT STATUS")

 +3        SET DIC("A")="PATIENT STATUS: "

 +4        SET DIC(0)="QEAMZ"

           SET DIC=53

           DO ^DIC

           KILL DIC

 +5        IF X[U

               IF $LENGTH(X)>1

                   DO JUMP^PSODIR1

                   GOTO PTSTATX

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

               SET PSODIR("DFLG")=1

               GOTO PTSTATX

 +7        IF Y=-1

               WRITE *7," Required"

               GOTO PTSTATEN

 +8        SET (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y

 +9        SET (PSODIR("PTST NODE"),PSORX("PTST NODE"))=Y(0)

PTSTATX    KILL DTOUT,DUOUT,Y,DA

 +1        QUIT 

 +2       ; Prompts for Substitution selection

 +3       ; IHS/MSC/PLS - 03/13/08

SUBS(PSODIR) ; EP - Substitution Enter/Edit

 +1        NEW DIR,DIC,Y,DA

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

 +3       ;IHS/MSC/PLS - 03/05/2013

 +4       ;S DIR("B")=$S($L($G(PSODIR("DAW"))):$$EXTERNAL^DILFD(52,9999999.25,,PSODIR("DAW")),1:"")

 +5        SET DIR("B")=$SELECT($LENGTH($GET(PSODIR("DAW"))):$$EXTERNAL^DILFD(52,9999999.25,,PSODIR("DAW")),$GET(PSODRUG("DAW")):PSODRUG("DAW"),1:"")