PSORENW3 ;IHS/DSD/JCM - EDIT TEMPLATE FOR RENEW RX ORDER ENTRY ;04-Jun-2013 13:07;DU
;;7.0;OUTPATIENT PHARMACY;**11,20,46,100,117,1006,1008,1017**;DEC 1997;Build 40
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^SC supported by DBIA 10040
;
; Modified - IHS/CIA/PLS - 01/06/04 - Numerous lines
; IHS/MSC/PLS - 08/20/07 - Line 451 now calls TRPDCLS^APSPDIR API
; 03/13/08 - Added label 68 and line DSPLY+22
; 01/23/09 - Added label 69 and lines DSPLY+24 and JUMP+4
; 06/04/13 - Changed label 69 to 70 and added label 69 and lines at DSPLY+24 and JUMP+4
;
START ;
D INIT
;
1 S PSORENW("FLD")=1 D ISSDT^PSODIR2(.PSORENW) ; Get Issue Date
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; IHS/CIA/PLS - 01/06/04 - Set APSRNEW
2 ;S PSORENW("FLD")=2 D FILLDT^PSODIR2(.PSORENW) ; Get Fill date
S PSORENW("FLD")=2,APSRNEW=1 D FILLDT^PSODIR2(.PSORENW) ; Get Fill date
D FFDTWARN^APSPFUNC($G(PSORENW("FILL DATE"))) ;IHS/CIA/PLS - 04/05/04 - Warn Future Fill Date
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
3 S PSORENW("FLD")=3 D PROV^PSODIR(.PSORENW) ; Get Provider
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; IHS/CIA/PLS - 01/06/04 - Added QTY prompt
40 S PSORENW("FLD")=40 D QTY^PSODIR1(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added Triplicate prompt
451 ;G:$G(PSOTRIP)'=1 501 ; Triplicate Switch
G:'$$TRPDCLS^APSPDIR($G(PSOTRIP),$G(PSODRUG("DEA"))) 501
45 S PSORENW("FLD")=45 D TRIP^APSPDIR(.PSORENW) ; Get Triplicate Number
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added NDC prompt
501 G:$G(PSONDC)'=1 601 ; NDC Field Switch
50 S PSORENW("FLD")=50 D NDC^APSPDIR(.PSORENW) ; Get NDC
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
K PSORENW("AWP")
K PSORENW("COST")
; IHS/CIA/PLS - 01/06/04 - Added AWP prompt
601 G:$G(PSOAWP)'=1 611
60 S PSORENW("FLD")=60 D AWP^APSPDIR(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added COST prompt
611 G:$G(PSOCOST)'=1 62 ; Cost Switch
61 S PSORENW("FLD")=61 D COST^APSPDIR(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added Manufacturer prompt
62 G:(($G(APSPMAN)=3)!($G(APSPMAN)="")) 4 G:$G(APSPMAN)=2 67 ; MANUF switch
63 S PSORENW("FLD")=63 D MANUF^APSPDIR(.PSORENW) ; Get Manufacturer
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added Lot # prompt
65 S PSORENW("FLD")=65 D LOT^APSPDIR(.PSORENW) ; Get Lot #
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/CIA/PLS - 01/06/04 - Added Expiration Date prompt
67 S PSORENW("FLD")=67 D EXPDATE^APSPDIR(.PSORENW) ; Get Expiration Date
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/MSC/PLS - 03/13/08 - Added Substitution prompt
68 S PSORENW("FLD")=68 D SUBS^APSPDIR(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/MSC/PLS - 06/04/13 - Added Discharge Medication
69 S PSORENW("FLD")=69 D DSCMED^APSPDIR(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
; IHS/MSC/PLS - 01/23/09 - Added Cash Due prompt
70 I $$GET1^DIQ(9009033,PSOSITE,319,"I") S PSORENW("FLD")=70 D CASHDUE^APSPDIR(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
4 S PSORENW("FLD")=4,PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
K PSORENW("# OF REFILLS") D REFILL^PSODIR1(.PSORENW) ; Get # of refills
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; IHS/CIA/PLS - 01/06/04 - Added Billing and Insurer prompts
S PSORENW("BST")=PSOBILST G:$G(PSOBILRX)'=1 5 ; Billing Switch
85 S PSORENW("FLD")=85 D BST^APSPDIR(.PSORENW) ; Get Billing Status Code
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; IHS/CIA/PLS - 01/06/04 - Added Insurer prompt
87 S PSORENW("FLD")=87 D INSURER^APSPDIR(.PSORENW) ; Get Insurer
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
5 S PSORENW("FLD")=5 D RMK^PSODIR2(.PSORENW) ; Get Remarks
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
6 S PSORENW("FLD")=6 D MW^PSODIR2(.PSORENW) ; Get Mail/Window Info
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; IHS/CIA/PLS - 01/06/04 - Commented out next two lines
7 ;I $G(DUZ("AG"))="I" S PSORENW("FLD")=7 D EXP^PSODIR2(.PSORENW) ; Get Expiration Date - Indian Health Service ONLY
;G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
8 I $G(DUZ("AG"))="I" S PSORENW("FLD")=8 D CLERK^PSODIR2(.PSORENW) ; Get Clerk Code
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
9 S PSORENW("FLD")=9 D CLINIC^PSODIR2(.PSORENW)
G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
;
; PLS - 06/21/04 ;S APFLAG="RE" D ^APSPQ ; IHS/CIA/PLS - 01/06/04 - Due Questionnaire
END ;
; IHS/CIA/PLS - 01/06/04 - Added next two lines
S:'$D(PSORENW("AWP")) PSORENW("AWP")=$$AWP^APSQDAWP($S($D(PSORENW("NDC")):PSORENW("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK)
S:'$D(PSORENW("PATIENT STATUS")) PSORENW("PATIENT STATUS")=PSORX("PATIENT STATUS")
K PSORENW3 S PSORENW("EDIT")=1
Q
;
INIT ;
S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7)
I '$G(PSORENW("DAYS SUPPLY")) S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
S (PSORENW("DFLG"),PSORENW("FIELD"),PSORENW3)=0
G:$G(PSORENW("EDIT")) INITX
S PSORENW("ISSUE DATE")=$S(DT>PSORENW("FILL DATE"):PSORENW("FILL DATE"),1:DT)
S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5)
I $G(PSOFDR),$P($G(OR0),"^",13) S PSORENW("CLINIC")=$P($G(OR0),"^",13)
S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(PSORENW("CLINIC"),0),"^")
S Y=PSORENW("FILL DATE") X ^DD("DD") S PSORX("FILL DATE")=Y K Y
S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4))
S PSORENW("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
S PSORENW("PTST NODE")=$G(^PS(53,$P(PSORENW("RX0"),"^",3),0))
S PSORENW("# OF REFILLS")=$S($G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
S PSORX("MAIL/WINDOW")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),$P(PSORENW("RX0"),"^",11)="W":"WINDOW",1:"MAIL")
S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^")
S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
F D=0:0 S D=$O(^PSRX(PSORENW("OIRXN"),"INS1",D)) Q:'D S PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
I '$O(PSORENW("DOSE",0)) F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
.S PSORENW("ENT")=$G(PSORENW("ENT"))+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
.S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
.S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
.S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
.I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
.K DOSE
I $P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2),'$O(SIG(0)) S SIGOK=1 D Q
.F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
.I '$O(SIG(0)),$G(ORD),$G(PSOORRNW) F I=0:0 S I=$O(^PS(52.41,ORD,"SIG",I)) Q:'I S SIG(I)=^PS(52.41,ORD,"SIG",I,0)
.I '$O(SIG(0)) S SIG(1)="This Prescription is MISSING Required Medication Instructions for the Patient. Please Review Dosaging Instructions."
I $P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")]"",'$P(^("SIG"),"^",2),'$O(SIG(0)) S SIGOK=1 D
.S X=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^") D SIG^PSOHELP I $G(INS1)]"" S SIG(1)=$E(INS1,2,999)
.I '$O(SIG(0)) S (PSORENW("SIG"),SIG(1))="This Prescription is MISSING Required Usable Medication Instructions for the Patient. Please Review Dosaging Instructions."
S PSORENW("NDC")=$G(PSODRUG("NDC")) ; IHS/CIA/PLS - 01/06/04
S PSORENW("AWP")=$G(PSODRUG("AWP")) ; IHS/CIA/PLS - 01/06/04
S PSORENW("COST")=$G(PSODRUG("COST")) ; IHS/CIA/PLS - 01/06/04
INITX Q
JUMP ;
S PSORENW("FIELD")=$S(+Y=1:1,+Y=22:2,+Y=4:3,+Y=5:9,+Y=9:4,+Y=12:5,+Y=11:6,+Y=29:7,+Y=16:8,1:PSORENW("FLD"))
; IHS/CIA/PLS - 01/06/04 - Added $S for additional fields
;S PSONEW("FIELD")=$S(+Y=7:40,+Y=9999999.13:45,+Y=27:50,+Y=9999999.06:60,+Y=17:61,+Y=28:63,+Y=24:65,+Y=26:67,+Y=9999999.07:85,+Y=9999999.12:87,1:PSONEW("FIELD"))
; IHS/MSC/PLS - 01/23/09 - Added 68 and 69 to $S
; IHS/MSC/PLS - 06/04/13 - changed 69 to 70 and added 69 to $S
S PSONEW("FIELD")=$S(+Y=7:40,+Y=9999999.13:45,+Y=27:50,+Y=9999999.06:60,+Y=17:61,+Y=28:63,+Y=24:65,+Y=26:67,+Y=9999999.07:85,+Y=9999999.12:87,+Y=9999999.25:68,+Y=9999999.28:69,+Y=9999999.26:70,1:PSONEW("FIELD"))
Q
DSPLY ;called from PSORENW0
W !!,PSORENW("NRX #"),?12," ",$P(^PSDRUG(PSORENW("DRUG IEN"),0),"^"),?46," QTY: ",$P(PSORENW("RX0"),"^",7)
W !,"# OF REFILLS: "_$S($G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
W " ISSUED: "_$S(DT>PSORENW("FILL DATE"):$E(PSORENW("FILL DATE"),4,5)_"-"_$E(PSORENW("FILL DATE"),6,7)_"-"_$E(PSORENW("FILL DATE"),2,3),1:$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3))
;S X=PSORENW("INS") D SIG^PSOHELP S PSORENW("SIG")=$E(INS1,2,9999999)
F DR=1:1:PSORENW("ENT") I $G(PSORENW("DURATION",DR))]"" D
.S DUR1=PSORENW("DURATION",DR)
.S PSORENW("DURATION",DR)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
F D=0:0 S D=$O(^PSRX(PSORENW("OIRXN"),"INS1",D)) Q:'D S PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
K DR,DUR1 ;D EN^PSOFSIG(.PSORENW)
I $G(SIGOK) D:'$O(SIG(0)) W !,"SIG: " F D=0:0 Q:'$O(SIG(D)) S D=$O(SIG(D)) W SIG(D),!
.F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
.I '$O(SIG(0)) S SIG(1)="This Prescription is MISSING Required Usable Medication Instructions",SIG(2)="for the Patient. Please Review Dosaging Instructions.",PSORENW("DFLG")=1
E W " SIG: "_PSORENW("SIG")_" "
W "FILLED: "_$E(PSORENW("FILL DATE"),4,5)_"-"_$E(PSORENW("FILL DATE"),6,7)_"-"_$E(PSORENW("FILL DATE"),2,3)
W !,"ROUTING: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL")
W " PHYS: "_PSORX("PROVIDER NAME"),!
; IHS/CIA/PLS - 01/06/04 - Added next three lines
W "NDC: ",$S($G(PSORENW("NDC"))]"":PSORENW("NDC"),1:$G(PSODRUG("NDC")))
W " ("_$S($G(PSORENW("AWP"))]"":PSORENW("AWP"),1:$G(PSODRUG("AWP")))_") "
W " ("_$S($G(PSORENW("COST"))]"":PSORENW("AWP"),1:$G(PSODRUG("COST")))_")"
; IHS/MSC/PLS - 03/13/08
W !,"SUBSTITUTION: "_$$EXTERNAL^DILFD(52,9999999.25,,$G(PSONEW("DAW")))
; IHS/MSC/PLS - 06/04/13
W !,"DISCHARGE MEDICATION: "_$$EXTERNAL^DILFD(52,9999999.28,,$G(PSONEW("DSCMED")))
;IHS/MSC/PLS - 01/23/09
W !,"CASH DUE: "_$$EXTERNAL^DILFD(52,9999999.26,,$G(PSONEW("CASH DUE")))
I $G(PSORENW("DFLG")),'$G(SPEED) K DIR S DIR(0)="E",DIR("A")="Rx NOT Renewed. Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT
DSPLYX Q
PSORENW3 ;IHS/DSD/JCM - EDIT TEMPLATE FOR RENEW RX ORDER ENTRY ;04-Jun-2013 13:07;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**11,20,46,100,117,1006,1008,1017**;DEC 1997;Build 40
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^SC supported by DBIA 10040
+4 ;
+5 ; Modified - IHS/CIA/PLS - 01/06/04 - Numerous lines
+6 ; IHS/MSC/PLS - 08/20/07 - Line 451 now calls TRPDCLS^APSPDIR API
+7 ; 03/13/08 - Added label 68 and line DSPLY+22
+8 ; 01/23/09 - Added label 69 and lines DSPLY+24 and JUMP+4
+9 ; 06/04/13 - Changed label 69 to 70 and added label 69 and lines at DSPLY+24 and JUMP+4
+10 ;
START ;
+1 DO INIT
+2 ;
1 ; Get Issue Date
SET PSORENW("FLD")=1
DO ISSDT^PSODIR2(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
+3 ; IHS/CIA/PLS - 01/06/04 - Set APSRNEW
2 ;S PSORENW("FLD")=2 D FILLDT^PSODIR2(.PSORENW) ; Get Fill date
+1 ; Get Fill date
SET PSORENW("FLD")=2
SET APSRNEW=1
DO FILLDT^PSODIR2(.PSORENW)
+2 ;IHS/CIA/PLS - 04/05/04 - Warn Future Fill Date
DO FFDTWARN^APSPFUNC($GET(PSORENW("FILL DATE")))
+3 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+4 ;
3 ; Get Provider
SET PSORENW("FLD")=3
DO PROV^PSODIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
+3 ; IHS/CIA/PLS - 01/06/04 - Added QTY prompt
40 SET PSORENW("FLD")=40
DO QTY^PSODIR1(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added Triplicate prompt
451 ;G:$G(PSOTRIP)'=1 501 ; Triplicate Switch
+1 IF '$$TRPDCLS^APSPDIR($GET(PSOTRIP),$GET(PSODRUG("DEA")))
GOTO 501
45 ; Get Triplicate Number
SET PSORENW("FLD")=45
DO TRIP^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added NDC prompt
501 ; NDC Field Switch
IF $GET(PSONDC)'=1
GOTO 601
50 ; Get NDC
SET PSORENW("FLD")=50
DO NDC^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 KILL PSORENW("AWP")
+3 KILL PSORENW("COST")
+4 ; IHS/CIA/PLS - 01/06/04 - Added AWP prompt
601 IF $GET(PSOAWP)'=1
GOTO 611
60 SET PSORENW("FLD")=60
DO AWP^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added COST prompt
611 ; Cost Switch
IF $GET(PSOCOST)'=1
GOTO 62
61 SET PSORENW("FLD")=61
DO COST^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added Manufacturer prompt
62 ; MANUF switch
IF (($GET(APSPMAN)=3)!($GET(APSPMAN)=""))
GOTO 4
IF $GET(APSPMAN)=2
GOTO 67
63 ; Get Manufacturer
SET PSORENW("FLD")=63
DO MANUF^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added Lot # prompt
65 ; Get Lot #
SET PSORENW("FLD")=65
DO LOT^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/CIA/PLS - 01/06/04 - Added Expiration Date prompt
67 ; Get Expiration Date
SET PSORENW("FLD")=67
DO EXPDATE^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/MSC/PLS - 03/13/08 - Added Substitution prompt
68 SET PSORENW("FLD")=68
DO SUBS^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/MSC/PLS - 06/04/13 - Added Discharge Medication
69 SET PSORENW("FLD")=69
DO DSCMED^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ; IHS/MSC/PLS - 01/23/09 - Added Cash Due prompt
70 IF $$GET1^DIQ(9009033,PSOSITE,319,"I")
SET PSORENW("FLD")=70
DO CASHDUE^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
4 SET PSORENW("FLD")=4
SET PSORENW("DAYS SUPPLY")=$PIECE(PSORENW("RX0"),"^",8)
+1 ; Get # of refills
KILL PSORENW("# OF REFILLS")
DO REFILL^PSODIR1(.PSORENW)
+2 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+3 ;
+4 ; IHS/CIA/PLS - 01/06/04 - Added Billing and Insurer prompts
+5 ; Billing Switch
SET PSORENW("BST")=PSOBILST
IF $GET(PSOBILRX)'=1
GOTO 5
85 ; Get Billing Status Code
SET PSORENW("FLD")=85
DO BST^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
+3 ; IHS/CIA/PLS - 01/06/04 - Added Insurer prompt
87 ; Get Insurer
SET PSORENW("FLD")=87
DO INSURER^APSPDIR(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
5 ; Get Remarks
SET PSORENW("FLD")=5
DO RMK^PSODIR2(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
6 ; Get Mail/Window Info
SET PSORENW("FLD")=6
DO MW^PSODIR2(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
+3 ; IHS/CIA/PLS - 01/06/04 - Commented out next two lines
7 ;I $G(DUZ("AG"))="I" S PSORENW("FLD")=7 D EXP^PSODIR2(.PSORENW) ; Get Expiration Date - Indian Health Service ONLY
+1 ;G:PSORENW("DFLG") END G:PSORENW("FIELD") @PSORENW("FIELD")
+2 ;
8 ; Get Clerk Code
IF $GET(DUZ("AG"))="I"
SET PSORENW("FLD")=8
DO CLERK^PSODIR2(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
9 SET PSORENW("FLD")=9
DO CLINIC^PSODIR2(.PSORENW)
+1 IF PSORENW("DFLG")
GOTO END
IF PSORENW("FIELD")
GOTO @PSORENW("FIELD")
+2 ;
+3 ; PLS - 06/21/04 ;S APFLAG="RE" D ^APSPQ ; IHS/CIA/PLS - 01/06/04 - Due Questionnaire
END ;
+1 ; IHS/CIA/PLS - 01/06/04 - Added next two lines
+2 IF '$DATA(PSORENW("AWP"))
SET PSORENW("AWP")=$$AWP^APSQDAWP($SELECT($DATA(PSORENW("NDC")):PSORENW("NDC"),1:PSODRUG("NDC")),PSODRUG("IEN"),.TALK)
+3 IF '$DATA(PSORENW("PATIENT STATUS"))
SET PSORENW("PATIENT STATUS")=PSORX("PATIENT STATUS")
+4 KILL PSORENW3
SET PSORENW("EDIT")=1
+5 QUIT
+6 ;
INIT ;
+1 SET PSORENW("QTY")=$PIECE(PSORENW("RX0"),"^",7)
+2 IF '$GET(PSORENW("DAYS SUPPLY"))
SET PSORENW("DAYS SUPPLY")=$PIECE(PSORENW("RX0"),"^",8)
+3 SET (PSORENW("DFLG"),PSORENW("FIELD"),PSORENW3)=0
+4 IF $GET(PSORENW("EDIT"))
GOTO INITX
+5 SET PSORENW("ISSUE DATE")=$SELECT(DT>PSORENW("FILL DATE"):PSORENW("FILL DATE"),1:DT)
+6 SET PSORENW("CLINIC")=$PIECE(PSORENW("RX0"),"^",5)
+7 IF $GET(PSOFDR)
IF $PIECE($GET(OR0),"^",13)
SET PSORENW("CLINIC")=$PIECE($GET(OR0),"^",13)
+8 IF PSORENW("CLINIC")
SET PSORX("CLINIC")=$PIECE(^SC(PSORENW("CLINIC"),0),"^")
+9 SET Y=PSORENW("FILL DATE")
XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
+10 SET PSORENW("PROVIDER")=$SELECT($GET(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$PIECE(PSORENW("RX0"),"^",4))
+11 SET PSORENW("PROVIDER NAME")=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),0)),"^")
+12 SET PSORENW("PTST NODE")=$GET(^PS(53,$PIECE(PSORENW("RX0"),"^",3),0))
+13 SET PSORENW("# OF REFILLS")=$SELECT($GET(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$PIECE(PSORENW("RX0"),"^",9))
+14 SET PSORENW("REMARKS")="RENEWED FROM RX # "_$PIECE(PSORENW("RX0"),"^")
+15 SET PSORX("MAIL/WINDOW")=$SELECT($GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),$PIECE(PSORENW("RX0"),"^",11)="W":"WINDOW",1:"MAIL")
+16 IF $GET(PSORX("CLERK CODE"))']""
SET PSORX("CLERK CODE")=$PIECE($GET(^VA(200,DUZ,0)),"^")
+17 SET PSORENW("INS")=$SELECT($GET(PSORENW("INS"))]"":PSORENW("INS"),1:$GET(^PSRX(PSORENW("OIRXN"),"INS")))
+18 FOR D=0:0
SET D=$ORDER(^PSRX(PSORENW("OIRXN"),"INS1",D))
IF 'D
QUIT
SET PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
+19 IF '$ORDER(PSORENW("DOSE",0))
FOR I=0:0
SET I=$ORDER(^PSRX(PSORENW("OIRXN"),6,I))
IF 'I
QUIT
SET DOSE=^PSRX(PSORENW("OIRXN"),6,I,0)
Begin DoDot:1
+20 SET PSORENW("ENT")=$GET(PSORENW("ENT"))+1
SET PSORENW("DOSE",PSORENW("ENT"))=$PIECE(DOSE,"^")
+21 SET PSORENW("UNITS",PSORENW("ENT"))=$PIECE(DOSE,"^",3)
SET PSORENW("DOSE ORDERED",PSORENW("ENT"))=$PIECE(DOSE,"^",2)
SET PSORENW("ROUTE",PSORENW("ENT"))=$PIECE(DOSE,"^",7)
+22 SET PSORENW("SCHEDULE",PSORENW("ENT"))=$PIECE(DOSE,"^",8)
SET PSORENW("DURATION",PSORENW("ENT"))=$PIECE(DOSE,"^",5)
SET PSORENW("CONJUNCTION",PSORENW("ENT"))=$PIECE(DOSE,"^",6)
+23 SET PSORENW("NOUN",PSORENW("ENT"))=$PIECE(DOSE,"^",4)
SET PSORENW("VERB",PSORENW("ENT"))=$PIECE(DOSE,"^",9)
+24 IF $GET(^PSRX(PSORENW("OIRXN"),6,I,1))]""
SET PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
+25 KILL DOSE
End DoDot:1
+26 IF $PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2)
IF '$ORDER(SIG(0))
SET SIGOK=1
Begin DoDot:1
+27 FOR I=0:0
SET I=$ORDER(^PSRX(PSORENW("OIRXN"),"SIG1",I))
IF 'I
QUIT
SET SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
+28 IF '$ORDER(SIG(0))
IF $GET(ORD)
IF $GET(PSOORRNW)
FOR I=0:0
SET I=$ORDER(^PS(52.41,ORD,"SIG",I))
IF 'I
QUIT
SET SIG(I)=^PS(52.41,ORD,"SIG",I,0)
+29 IF '$ORDER(SIG(0))
SET SIG(1)="This Prescription is MISSING Required Medication Instructions for the Patient. Please Review Dosaging Instructions."
End DoDot:1
QUIT
+30 IF $PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^")]""
IF '$PIECE(^("SIG"),"^",2)
IF '$ORDER(SIG(0))
SET SIGOK=1
Begin DoDot:1
+31 SET X=$PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
DO SIG^PSOHELP
IF $GET(INS1)]""
SET SIG(1)=$EXTRACT(INS1,2,999)
+32 IF '$ORDER(SIG(0))
SET (PSORENW("SIG"),SIG(1))="This Prescription is MISSING Required Usable Medication Instructions for the Patient. Please Review Dosaging Instructions."
End DoDot:1
+33 ; IHS/CIA/PLS - 01/06/04
SET PSORENW("NDC")=$GET(PSODRUG("NDC"))
+34 ; IHS/CIA/PLS - 01/06/04
SET PSORENW("AWP")=$GET(PSODRUG("AWP"))
+35 ; IHS/CIA/PLS - 01/06/04
SET PSORENW("COST")=$GET(PSODRUG("COST"))
INITX QUIT
JUMP ;
+1 SET PSORENW("FIELD")=$SELECT(+Y=1:1,+Y=22:2,+Y=4:3,+Y=5:9,+Y=9:4,+Y=12:5,+Y=11:6,+Y=29:7,+Y=16:8,1:PSORENW("FLD"))
+2 ; IHS/CIA/PLS - 01/06/04 - Added $S for additional fields
+3 ;S PSONEW("FIELD")=$S(+Y=7:40,+Y=9999999.13:45,+Y=27:50,+Y=9999999.06:60,+Y=17:61,+Y=28:63,+Y=24:65,+Y=26:67,+Y=9999999.07:85,+Y=9999999.12:87,1:PSONEW("FIELD"))
+4 ; IHS/MSC/PLS - 01/23/09 - Added 68 and 69 to $S
+5 ; IHS/MSC/PLS - 06/04/13 - changed 69 to 70 and added 69 to $S
+6 SET PSONEW("FIELD")=$SELECT(+Y=7:40,+Y=9999999.13:45,+Y=27:50,+Y=9999999.06:60,+Y=17:61,+Y=28:63,+Y=24:65,+Y=26:67,+Y=9999999.07:85,+Y=9999999.12:87,+Y=9999999.25:68,+Y=9999999.28:69,+Y=9999999.26:70,1:PSONEW("FIELD"))
+7 QUIT
DSPLY ;called from PSORENW0
+1 WRITE !!,PSORENW("NRX #"),?12," ",$PIECE(^PSDRUG(PSORENW("DRUG IEN"),0),"^"),?46," QTY: ",$PIECE(PSORENW("RX0"),"^",7)
+2 WRITE !,"# OF REFILLS: "_$SELECT($GET(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$PIECE(PSORENW("RX0"),"^",9))
+3 WRITE " ISSUED: "_$SELECT(DT>PSORENW("FILL DATE"):$EXTRACT(PSORENW("FILL DATE"),4,5)_"-"_$EXTRACT(PSORENW("FILL DATE"),6,7)_"-"_$EXTRACT(PSORENW("FILL DATE"),2,3),1:$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3))
+4 ;S X=PSORENW("INS") D SIG^PSOHELP S PSORENW("SIG")=$E(INS1,2,9999999)
+5 FOR DR=1:1:PSORENW("ENT")
IF $GET(PSORENW("DURATION",DR))]""
Begin DoDot:1
+6 SET DUR1=PSORENW("DURATION",DR)
+7 SET PSORENW("DURATION",DR)=$SELECT($EXTRACT(DUR1,1)'?.N:$EXTRACT(DUR1,2,99)_$EXTRACT(DUR1,1),1:DUR1)
End DoDot:1
+8 FOR D=0:0
SET D=$ORDER(^PSRX(PSORENW("OIRXN"),"INS1",D))
IF 'D
QUIT
SET PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
+9 ;D EN^PSOFSIG(.PSORENW)
KILL DR,DUR1
+10 IF $GET(SIGOK)
IF '$ORDER(SIG(0))
Begin DoDot:1
+11 FOR I=0:0
SET I=$ORDER(^PSRX(PSORENW("OIRXN"),"SIG1",I))
IF 'I
QUIT
SET SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
+12 IF '$ORDER(SIG(0))
SET SIG(1)="This Prescription is MISSING Required Usable Medication Instructions"
SET SIG(2)="for the Patient. Please Review Dosaging Instructions."
SET PSORENW("DFLG")=1
End DoDot:1
WRITE !,"SIG: "
FOR D=0:0
IF '$ORDER(SIG(D))
QUIT
SET D=$ORDER(SIG(D))
WRITE SIG(D),!
+13 IF '$TEST
WRITE " SIG: "_PSORENW("SIG")_" "
+14 WRITE "FILLED: "_$EXTRACT(PSORENW("FILL DATE"),4,5)_"-"_$EXTRACT(PSORENW("FILL DATE"),6,7)_"-"_$EXTRACT(PSORENW("FILL DATE"),2,3)
+15 WRITE !,"ROUTING: "_$SELECT($GET(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL")
+16 WRITE " PHYS: "_PSORX("PROVIDER NAME"),!
+17 ; IHS/CIA/PLS - 01/06/04 - Added next three lines
+18 WRITE "NDC: ",$SELECT($GET(PSORENW("NDC"))]"":PSORENW("NDC"),1:$GET(PSODRUG("NDC")))
+19 WRITE " ("_$SELECT($GET(PSORENW("AWP"))]"":PSORENW("AWP"),1:$GET(PSODRUG("AWP")))_") "
+20 WRITE " ("_$SELECT($GET(PSORENW("COST"))]"":PSORENW("AWP"),1:$GET(PSODRUG("COST")))_")"
+21 ; IHS/MSC/PLS - 03/13/08
+22 WRITE !,"SUBSTITUTION: "_$$EXTERNAL^DILFD(52,9999999.25,,$GET(PSONEW("DAW")))
+23 ; IHS/MSC/PLS - 06/04/13
+24 WRITE !,"DISCHARGE MEDICATION: "_$$EXTERNAL^DILFD(52,9999999.28,,$GET(PSONEW("DSCMED")))
+25 ;IHS/MSC/PLS - 01/23/09
+26 WRITE !,"CASH DUE: "_$$EXTERNAL^DILFD(52,9999999.26,,$GET(PSONEW("CASH DUE")))
+27 IF $GET(PSORENW("DFLG"))
IF '$GET(SPEED)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Rx NOT Renewed. Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DTOUT,DUOUT
DSPLYX QUIT
