PSOCPF2 ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
;;7.0;OUTPATIENT PHARMACY;**463,618,636**;DEC 1997;Build 14
;
Q
;^TMP($J,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
;
PATACP ; ACTION - Account Profile (AP)
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)))
D CLEAR^VALM1
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. N RCDEBTDA
.. S RC=$G(^TMP($J,"PSOCPFX",IBXX))
.. S RCDEBTDA=$P(RC,U,9) ;Need DEBTOR for AP
.. I 'RCDEBTDA D Q
... W !!,"There is no Bill associated with this entry."
... D PAUSE^VALM1
.. D EN^VALM("RCDP ACCOUNT PROFILE")
D BLD^PSOCPF
S VALMBCK="R"
Q
;
BILPRO ; view BILL PROFILE
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,REC,RCBILLDA
D EN^VALM2($G(XQORNOD(0)))
;PSO*7*636
D CLEAR^VALM1
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
.. S RCBILLDA=$P(REC,U,6)
.. I RCBILLDA="" D Q
... W !!,"There is no Bill associated with this entry."
... D PAUSE^VALM1
.. D EN^VALM("RCDP BILL PROFILE")
D BLD^PSOCPF
S VALMBCK="R"
Q
;
TPJI ; view THIRD PARTY JOIN INQUIRY
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
.. S DFN=$P(REC,U,2)
.. D EN^VALM("IBJT ACTIVE LIST")
D BLD^PSOCPF
S VALMBCK="R"
Q
;
BILINQ ; view PATIENT BILLING INQUIRY
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,IBIL,REC,IBFULL,IBIFN
D EN^VALM2($G(XQORNOD(0)))
;PSO*7*636
D CLEAR^VALM1
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
.. S IBIL=$P(REC,U,5),IBFULL=1,IBIFN=""
.. I IBIL="" D Q
... W !!,"There is no Bill associated with this entry."
... D PAUSE^VALM1
.. D EN^IBOLK
D BLD^PSOCPF
S VALMBCK="R"
Q
;
PATINQ ; view PATIENT INQUIRY
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
.. S DFN=$P(REC,U,2)
.. D EN^DGRPD
D BLD^PSOCPF
S VALMBCK="R"
Q
;
NP ; -- change patient,date and prescriptions.
N VALMQUIT,IBDFN,PAT,DFN,SDATE,TDATE,IBDATES,SAVFIL
;PSO*7*618 MOVE NEW HERE FROM ASKRX
N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
D FULL^VALM1
I $D(^TMP($J,"PSOCPFF",0)) S FILTERS(0)=^TMP($J,"PSOCPFF",0),SAVFIL(0)=FILTERS(0)
S R=""
F S R=$O(^TMP($J,"PSOCPFF",1,R)) Q:R="" S SAVFIL(1,R)=^TMP($J,"PSOCPFF",1,R)
;
;K ^TMP($J,"PSOCPFF") ;pso*7*618 fix/rewrite
S IBDFN=$P(FILTERS(0),U,4)
S PAT=$$ONEPAT^PSOCPF()
I PAT=-1 D RESET S VALMBCK="R" G NPQ
S (DFN,$P(FILTERS(0),U,4))=+PAT
S SDATE=$P(FILTERS(0),U,1)
S TDATE=$P(FILTERS(0),U,2)
;PSO*7*618 FIX/REWRITE CALL FMDATES IN THIS ROUTINE
S IBDATES="Fill Dates",IBDATES=$$FMDATES(IBDATES,SDATE,TDATE)
;PSO *7*618 FIX/REWRITE Return to LM screen
I IBDATES=-1 D RESET S VALMBCK="R" G NPQ
I $D(VALMQUIT) D RESET S VALMBCK="R" G NPQ
;PSO*7*618 CALL ADDRX IN THIS ROUTINE
D ADDRX^PSOCPF2
;PSO *7*618 FIX/REWRITE Return to LM screen
I Y="^"!(Y<0) D RESET S VALMBCK="R" G NPQ
S $P(FILTERS(0),U,1)=$P(IBDATES,U,1),$P(FILTERS(0),U,2)=$P(IBDATES,U,2)
S ^TMP($J,"PSOCPF")=FILTERS(0)
S R=""
F S R=$O(FILTERS(1,R)) Q:R="" S ^TMP($J,"PSOCPFF",1,R)=FILTERS(1,R)
W !,"Please be patient while I gather the requested data.",!
S VALMBG=1 D SORT^PSOCPF1,HDR^PSOCPF,BLD^PSOCPF
S VALMBCK="R"
NPQ Q
;
RESET ; Reset filters to current patient
S (DFN,$P(FILTERS(0),U,4))=IBDFN
S FILTERS(0)=$G(SAVFIL(0)) ;pso*7*618 ADD $g
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S RXS=$P(FILTERS(0),U,3),PAT=$P(FILTERS(0),U,4)
S ^TMP($J,"PSOCPFF",0)=FILTERS(0)
S R=""
F S R=$O(SAVFIL(1,R)) Q:R="" S (FILTERS(1,R),^TMP($J,"PSOCPFF",1,R))=SAVFIL(1,R)
Q
;PSO*7*618 FIX/REWRITE - COPIED FROM PSOCPF
FMDATES(PROMPT,SDT,EDT) ; ask for date range
N %DT,X,Y,DT1,DT2,IB0,IB1,IB2
S DT1="",IB1="Start with date entered: ",IB2="Go to date entered: "
I $G(PROMPT)'="" S IB1="Start with "_PROMPT_": ",IB2="Go to "_PROMPT_": "
I $D(SDT) K %DT S Y=SDT D DD^%DT S %DT("B")=Y
;
S %DT="AEX",%DT("A")=IB1 D ^%DT K %DT
;PSO 618 PASS -1 BACK
I Y<0!($P(Y,".",1)'?7N) Q -1
S (%DT(0),DT2)=$P(Y,".",1) I DT2'>DT,'$D(EDT) S %DT("B")="Today"
;
I $D(EDT) K %DT S Y=EDT D DD^%DT S %DT("B")=Y
;
S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT
;PSO 618 PASS -1 BACK
I Y<0!($P(Y,".",1)'?7N) Q -1
S DT1=DT2_U_$P(Y,".",1)
FMDQ Q DT1
;
;PSO*7*618 FIX/REWRITE COPIED FROM PSOCPF
ADDRX ;
; Prescription filter
S DIR(0)="S",DIR("A")="Select(A)ll or (S)elected Prescription(s)",DIR("B")="All"
S DIR("?",1)="Enter 'A' to not filter by Prescriptions."
S DIR("?")="Enter 'S' to view entries for selected Prescription(s)."
S $P(DIR(0),U,2)="A:All Prescriptions;S:Selected Prescriptions"
W ! D ^DIR K DIR
;PSO 618 add DIRUT exit
I $G(DIRUT)!(Y=-1) Q
S X=$$UP^XLFSTR(X)
S $P(FILTERS(0),U,3)=$S(Y="A":0,1:1)
;
I $P(FILTERS(0),U,3)=1 D ASKRX(.FILTERS)
;
Q
ASKRX(FILTERS) ; Sets a list of PrescriptionS to be displayed
; Input: FILTERS - Current Array of filter settings
; Output: FILTERS - Updated Array of filter settings
;PSO*7*618 MOVE TO NP
;N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
S DIC=52,DIC(0)="AEQMN",FIRST=1
K FILTERS(1)
F D Q:+IEN<1
. D ONERX(.DIC,.IEN,.FIRST) ; One Prescription prompt
. Q:+IEN<1
. S PSOIENS($P(IEN,U,2))=$P(IEN,U,1)
. S PSOIENS2($P(IEN,U,1))=$P(IEN,U,2)
I '$D(PSOIENS) S $P(FILTERS(0),U,3)=0 Q
;
; Set the filter node responses in alphabetical order
S XX=""
F D Q:XX=""
. S XX=$O(PSOIENS(XX))
. Q:XX=""
. S N=PSOIENS(XX)
. S FILTERS(1,N)=XX
Q
ONERX(DIC,IEN,FIRST) ; Prompts the user for a Medication
; Input: DIC - Variable/Array of settings needed for ^DIC call
; FIRST - Set to 1 initially and then 0 for subsequent calls
; Output: FIRST - Set to 0
; IEN - IEN of the selected Division
; null of no selection was made
S DIC("A")=$S(FIRST:"Select a Prescription: ",1:"Select Another Prescription: ")
D ^DIC
S FIRST=0,IEN=Y
I Y=-1 D RESET S VALMBCK="R" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPF2 6463 printed Nov 22, 2024@17:35:56 Page 2
PSOCPF2 ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
+1 ;;7.0;OUTPATIENT PHARMACY;**463,618,636**;DEC 1997;Build 14
+2 ;
+3 QUIT
+4 ;^TMP($J,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
+5 ;
PATACP ; ACTION - Account Profile (AP)
+1 DO FULL^VALM1
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 DO CLEAR^VALM1
+4 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+5 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+6 NEW RCDEBTDA
+7 SET RC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
+8 ;Need DEBTOR for AP
SET RCDEBTDA=$PIECE(RC,U,9)
+9 IF 'RCDEBTDA
Begin DoDot:3
+10 WRITE !!,"There is no Bill associated with this entry."
+11 DO PAUSE^VALM1
End DoDot:3
QUIT
+12 DO EN^VALM("RCDP ACCOUNT PROFILE")
End DoDot:2
End DoDot:1
+13 DO BLD^PSOCPF
+14 SET VALMBCK="R"
+15 QUIT
+16 ;
BILPRO ; view BILL PROFILE
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,REC,RCBILLDA
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 ;PSO*7*636
+5 DO CLEAR^VALM1
+6 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+7 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+8 SET REC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
+9 SET RCBILLDA=$PIECE(REC,U,6)
+10 IF RCBILLDA=""
Begin DoDot:3
+11 WRITE !!,"There is no Bill associated with this entry."
+12 DO PAUSE^VALM1
End DoDot:3
QUIT
+13 DO EN^VALM("RCDP BILL PROFILE")
End DoDot:2
End DoDot:1
+14 DO BLD^PSOCPF
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
TPJI ; view THIRD PARTY JOIN INQUIRY
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+5 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+6 SET REC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
+7 SET DFN=$PIECE(REC,U,2)
+8 DO EN^VALM("IBJT ACTIVE LIST")
End DoDot:2
End DoDot:1
+9 DO BLD^PSOCPF
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
BILINQ ; view PATIENT BILLING INQUIRY
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,DFN,GOPAT,IBIL,REC,IBFULL,IBIFN
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 ;PSO*7*636
+5 DO CLEAR^VALM1
+6 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+7 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+8 SET REC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
+9 SET IBIL=$PIECE(REC,U,5)
SET IBFULL=1
SET IBIFN=""
+10 IF IBIL=""
Begin DoDot:3
+11 WRITE !!,"There is no Bill associated with this entry."
+12 DO PAUSE^VALM1
End DoDot:3
QUIT
+13 DO EN^IBOLK
End DoDot:2
End DoDot:1
+14 DO BLD^PSOCPF
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
PATINQ ; view PATIENT INQUIRY
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+5 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+6 SET REC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
+7 SET DFN=$PIECE(REC,U,2)
+8 DO EN^DGRPD
End DoDot:2
End DoDot:1
+9 DO BLD^PSOCPF
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
NP ; -- change patient,date and prescriptions.
+1 NEW VALMQUIT,IBDFN,PAT,DFN,SDATE,TDATE,IBDATES,SAVFIL
+2 ;PSO*7*618 MOVE NEW HERE FROM ASKRX
+3 NEW DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
+4 DO FULL^VALM1
+5 IF $DATA(^TMP($JOB,"PSOCPFF",0))
SET FILTERS(0)=^TMP($JOB,"PSOCPFF",0)
SET SAVFIL(0)=FILTERS(0)
+6 SET R=""
+7 FOR
SET R=$ORDER(^TMP($JOB,"PSOCPFF",1,R))
if R=""
QUIT
SET SAVFIL(1,R)=^TMP($JOB,"PSOCPFF",1,R)
+8 ;
+9 ;K ^TMP($J,"PSOCPFF") ;pso*7*618 fix/rewrite
+10 SET IBDFN=$PIECE(FILTERS(0),U,4)
+11 SET PAT=$$ONEPAT^PSOCPF()
+12 IF PAT=-1
DO RESET
SET VALMBCK="R"
GOTO NPQ
+13 SET (DFN,$PIECE(FILTERS(0),U,4))=+PAT
+14 SET SDATE=$PIECE(FILTERS(0),U,1)
+15 SET TDATE=$PIECE(FILTERS(0),U,2)
+16 ;PSO*7*618 FIX/REWRITE CALL FMDATES IN THIS ROUTINE
+17 SET IBDATES="Fill Dates"
SET IBDATES=$$FMDATES(IBDATES,SDATE,TDATE)
+18 ;PSO *7*618 FIX/REWRITE Return to LM screen
+19 IF IBDATES=-1
DO RESET
SET VALMBCK="R"
GOTO NPQ
+20 IF $DATA(VALMQUIT)
DO RESET
SET VALMBCK="R"
GOTO NPQ
+21 ;PSO*7*618 CALL ADDRX IN THIS ROUTINE
+22 DO ADDRX^PSOCPF2
+23 ;PSO *7*618 FIX/REWRITE Return to LM screen
+24 IF Y="^"!(Y<0)
DO RESET
SET VALMBCK="R"
GOTO NPQ
+25 SET $PIECE(FILTERS(0),U,1)=$PIECE(IBDATES,U,1)
SET $PIECE(FILTERS(0),U,2)=$PIECE(IBDATES,U,2)
+26 SET ^TMP($JOB,"PSOCPF")=FILTERS(0)
+27 SET R=""
+28 FOR
SET R=$ORDER(FILTERS(1,R))
if R=""
QUIT
SET ^TMP($JOB,"PSOCPFF",1,R)=FILTERS(1,R)
+29 WRITE !,"Please be patient while I gather the requested data.",!
+30 SET VALMBG=1
DO SORT^PSOCPF1
DO HDR^PSOCPF
DO BLD^PSOCPF
+31 SET VALMBCK="R"
NPQ QUIT
+1 ;
RESET ; Reset filters to current patient
+1 SET (DFN,$PIECE(FILTERS(0),U,4))=IBDFN
+2 ;pso*7*618 ADD $g
SET FILTERS(0)=$GET(SAVFIL(0))
+3 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+4 SET RXS=$PIECE(FILTERS(0),U,3)
SET PAT=$PIECE(FILTERS(0),U,4)
+5 SET ^TMP($JOB,"PSOCPFF",0)=FILTERS(0)
+6 SET R=""
+7 FOR
SET R=$ORDER(SAVFIL(1,R))
if R=""
QUIT
SET (FILTERS(1,R),^TMP($JOB,"PSOCPFF",1,R))=SAVFIL(1,R)
+8 QUIT
+9 ;PSO*7*618 FIX/REWRITE - COPIED FROM PSOCPF
FMDATES(PROMPT,SDT,EDT) ; ask for date range
+1 NEW %DT,X,Y,DT1,DT2,IB0,IB1,IB2
+2 SET DT1=""
SET IB1="Start with date entered: "
SET IB2="Go to date entered: "
+3 IF $GET(PROMPT)'=""
SET IB1="Start with "_PROMPT_": "
SET IB2="Go to "_PROMPT_": "
+4 IF $DATA(SDT)
KILL %DT
SET Y=SDT
DO DD^%DT
SET %DT("B")=Y
+5 ;
+6 SET %DT="AEX"
SET %DT("A")=IB1
DO ^%DT
KILL %DT
+7 ;PSO 618 PASS -1 BACK
+8 IF Y<0!($PIECE(Y,".",1)'?7N)
QUIT -1
+9 SET (%DT(0),DT2)=$PIECE(Y,".",1)
IF DT2'>DT
IF '$DATA(EDT)
SET %DT("B")="Today"
+10 ;
+11 IF $DATA(EDT)
KILL %DT
SET Y=EDT
DO DD^%DT
SET %DT("B")=Y
+12 ;
+13 SET %DT="AEX"
SET %DT("A")=IB2
DO ^%DT
KILL %DT
+14 ;PSO 618 PASS -1 BACK
+15 IF Y<0!($PIECE(Y,".",1)'?7N)
QUIT -1
+16 SET DT1=DT2_U_$PIECE(Y,".",1)
FMDQ QUIT DT1
+1 ;
+2 ;PSO*7*618 FIX/REWRITE COPIED FROM PSOCPF
ADDRX ;
+1 ; Prescription filter
+2 SET DIR(0)="S"
SET DIR("A")="Select(A)ll or (S)elected Prescription(s)"
SET DIR("B")="All"
+3 SET DIR("?",1)="Enter 'A' to not filter by Prescriptions."
+4 SET DIR("?")="Enter 'S' to view entries for selected Prescription(s)."
+5 SET $PIECE(DIR(0),U,2)="A:All Prescriptions;S:Selected Prescriptions"
+6 WRITE !
DO ^DIR
KILL DIR
+7 ;PSO 618 add DIRUT exit
+8 IF $GET(DIRUT)!(Y=-1)
QUIT
+9 SET X=$$UP^XLFSTR(X)
+10 SET $PIECE(FILTERS(0),U,3)=$SELECT(Y="A":0,1:1)
+11 ;
+12 IF $PIECE(FILTERS(0),U,3)=1
DO ASKRX(.FILTERS)
+13 ;
+14 QUIT
ASKRX(FILTERS) ; Sets a list of PrescriptionS to be displayed
+1 ; Input: FILTERS - Current Array of filter settings
+2 ; Output: FILTERS - Updated Array of filter settings
+3 ;PSO*7*618 MOVE TO NP
+4 ;N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
+5 SET DIC=52
SET DIC(0)="AEQMN"
SET FIRST=1
+6 KILL FILTERS(1)
+7 FOR
Begin DoDot:1
+8 ; One Prescription prompt
DO ONERX(.DIC,.IEN,.FIRST)
+9 if +IEN<1
QUIT
+10 SET PSOIENS($PIECE(IEN,U,2))=$PIECE(IEN,U,1)
+11 SET PSOIENS2($PIECE(IEN,U,1))=$PIECE(IEN,U,2)
End DoDot:1
if +IEN<1
QUIT
+12 IF '$DATA(PSOIENS)
SET $PIECE(FILTERS(0),U,3)=0
QUIT
+13 ;
+14 ; Set the filter node responses in alphabetical order
+15 SET XX=""
+16 FOR
Begin DoDot:1
+17 SET XX=$ORDER(PSOIENS(XX))
+18 if XX=""
QUIT
+19 SET N=PSOIENS(XX)
+20 SET FILTERS(1,N)=XX
End DoDot:1
if XX=""
QUIT
+21 QUIT
ONERX(DIC,IEN,FIRST) ; Prompts the user for a Medication
+1 ; Input: DIC - Variable/Array of settings needed for ^DIC call
+2 ; FIRST - Set to 1 initially and then 0 for subsequent calls
+3 ; Output: FIRST - Set to 0
+4 ; IEN - IEN of the selected Division
+5 ; null of no selection was made
+6 SET DIC("A")=$SELECT(FIRST:"Select a Prescription: ",1:"Select Another Prescription: ")
+7 DO ^DIC
+8 SET FIRST=0
SET IEN=Y
+9 IF Y=-1
DO RESET
SET VALMBCK="R"
QUIT
+10 QUIT
