PSORENW3.m

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