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:"")
+6 DO DIR^PSODIR1
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO SUBSX
+7 SET PSODIR("DAW")=Y
SUBSX QUIT
+1 ; Prompts for Cash Due
CASHDUE(PSODIR) ; EP - Cash Due Enter/Edit
+1 NEW DIR,DIC,Y,DA
+2 SET DIR(0)="52,9999999.26"
+3 SET DIR("B")=$SELECT($LENGTH($GET(PSODIR("CASH DUE"))):$$EXTERNAL^DILFD(52,9999999.26,,PSODIR("CASH DUE")),1:"")
+4 DO DIR^PSODIR1
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO CASHDUEX
+5 SET PSODIR("CASH DUE")=Y
CASHDUEX QUIT
+1 ; Prompts for Discharge Medication
+2 ; IHS/MSC/PLS - 06/05/13
DSCMED(PSODIR) ; EP - Discharge Medication Enter/Edit
+1 ;P1018
IF $$GET1^DIQ(9009033,PSOSITE,408,"I")
QUIT
+2 NEW DIR,DIC,Y,DA,OVAL,CFRM,DVAL
+3 SET CFRM(1)="This field should be marked YES for all discharge medications"
+4 SET CFRM(2)="from In-House Inpatient Unit or In-House Emergency Department."
+5 SET CFRM="Are you sure you want to edit"
+6 SET OVAL=$GET(PSODIR("DSCMED"))
+7 SET DIR(0)="52,9999999.28"
+8 SET DIR("A")="DISCHARGE MEDICATION (In-House Inpatient/ER only)"
+9 SET DIR("B")=$SELECT($LENGTH($GET(PSODIR("DSCMED"))):$$EXTERNAL^DILFD(52,9999999.28,,PSODIR("DSCMED")),$$INP^SDAM2(PSODFN,DT)="I":"Yes",1:"")
+10 SET DIR("?")=" "
+11 SET DIR("?",1)="Enter YES if this is a discharge medication from the In-House"
+12 SET DIR("?",2)="Inpatient unit or In-House Emergency Department."
+13 SET DIR("?",3)="This should ONLY be entered for In-House discharge medications"
+14 SET DIR("?",4)="and not external discharge medications from other hospitals"
+15 SET DIR("?",5)="or emergency departments."
+16 SET DVAL=DIR("B")
+17 DO DIR^PSODIR1
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO DSCMEDX
+18 IF DVAL=""
IF Y=""
Begin DoDot:1
+19 SET PSODIR("DSCMED")=Y
End DoDot:1
+20 IF '$TEST
IF DVAL="NO"
IF Y=0
Begin DoDot:1
+21 SET PSODIR("DSCMED")=Y
End DoDot:1
+22 IF '$TEST
IF DVAL="YES"
IF Y=1
Begin DoDot:1
+23 SET PSODIR("DSCMED")=Y
End DoDot:1
+24 IF '$TEST
IF DVAL="Yes"
IF Y=1
Begin DoDot:1
+25 SET PSODIR("DSCMED")=Y
End DoDot:1
+26 ;I OVAL="",+Y D
+27 ;.I $$DIRYNR^APSPUTIL(.CFRM,"NO") D
+28 ;..S PSODIR("DSCMED")=Y
+29 ;.E S PSODIR("DSCMED")=0
+30 ;E I OVAL="" S PSODIR("DSCMED")=Y
+31 ;I (OVAL'=+Y) D
IF '$TEST
Begin DoDot:1
+32 IF $$DIRYNR^APSPUTIL(.CFRM,"NO")
Begin DoDot:2
+33 SET PSODIR("DSCMED")=Y
End DoDot:2
End DoDot:1
DSCMEDX QUIT
+1 ; Allows editing of template
EDIHSFLD(DA,IT,GLOBAL) ;EP
+1 ;N DA,DIR,DIRUT,DIROUT,DIE,DR
+2 ;S DA=PSODIR("IRXN")
+3 SET DIE=GLOBAL
SET DR=IT
+4 DO ^DIE
+5 QUIT
+6 ; EP - Field Prompt
+7 ; Input - PSONEW - Array of values for prescription
+8 ; SETFLD - Set "FLD" subnode array (default: No)
IHSFLDS(PSONEW,SETFLD) ;EP
+1 SET SETFLD=$GET(SETFLD,0)
+2 WRITE !!
1 Begin DoDot:1
+1 SET PSONEW("FLD")=1
DO TRIP^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("TRIP")))
SET PSONEW("FLD",9999999.14)=PSONEW("TRIP")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
2 Begin DoDot:1
+1 SET PSONEW("FLD")=2
DO NDC^APSPDIR(.PSONEW)
+2 KILL PSONEW("AWP"),PSONEW("COST")
+3 IF SETFLD
IF $LENGTH($GET(PSONEW("NDC")))
SET PSONEW("FLD",27)=PSONEW("NDC")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
3 Begin DoDot:1
+1 SET PSONEW("FLD")=3
DO AWP^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("AWP")))
SET PSONEW("FLD",9999999.06)=PSONEW("AWP")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
4 Begin DoDot:1
+1 SET PSONEW("FLD")=4
DO COST^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("COST")))
SET PSONEW("FLD",17)=PSONEW("COST")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
5 Begin DoDot:1
+1 SET PSONEW("FLD")=5
DO MANUF^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("MANUFACTURER")))
SET PSONEW("FLD",28)=PSONEW("MANUFACTURER")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
6 Begin DoDot:1
+1 SET PSONEW("FLD")=6
DO EXPDATE^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $DATA(PSONEW("EXPIRATION DATE"))
SET PSONEW("FLD",29)=PSONEW("EXPIRATION DATE")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
7 ;S PSONEW("FLD")=7 D INSURER^APSPDIR(.PSONEW)
+1 ;G:PSONEW("DFLG") END
8 Begin DoDot:1
+1 SET PSONEW("FLD")=8
DO CM^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("CM")))
SET PSONEW("FLD",9999999.02)=PSONEW("CM")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
9 Begin DoDot:1
+1 SET PSONEW("FLD")=9
DO BST^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("BST")))
SET PSONEW("FLD",9999999.07)=PSONEW("BST")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
10 ;D G:PSONEW("DFLG") END
+1 ;.S PSONEW("FLD")=10 D SUBS^APSPDIR(.PSONEW)
+2 ;.I SETFLD,$L($G(PSONEW("DAW"))) S PSONEW("FLD",9999999.25)=PSONEW("DAW")
11 Begin DoDot:1
+1 SET PSONEW("FLD")=11
DO DSCMED^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("DSCMED")))
SET PSONEW("FLD",9999999.28)=PSONEW("DSCMED")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
12 Begin DoDot:1
+1 SET PSONEW("FLD")=12
DO CASHDUE^APSPDIR(.PSONEW)
+2 IF SETFLD
IF $LENGTH($GET(PSONEW("CASH DUE")))
SET PSONEW("FLD",9999999.26)=PSONEW("CASH DUE")
End DoDot:1
IF PSONEW("DFLG")
GOTO END
END QUIT
