PSOREJP3 ;ALB/SS - Third Party Reject Display Screen - Comments ;10/27/06
;;7.0;OUTPATIENT PHARMACY;**260,287,289**;DEC 1997;Build 107
;
COM ; Builds the Comments section in the Reject Display Screen
I +$O(^PSRX(RX,"REJ",REJ,"COM",0))=0 Q
D SETLN^PSOREJP1()
D SETLN^PSOREJP1("COMMENTS",1,1)
N DIWL,DIWR,LNCNT,MAXLN,PSL
N I,X,PSI,Y,LAST,PSOCOM,TXTLN
S PSI=999999
F S PSI=$O(^PSRX(RX,"REJ",REJ,"COM",PSI),-1) Q:+PSI=0 D
. S PSCOM=$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,.01)_" - "
. S PSCOM=PSCOM_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,2)
. S PSCOM=PSCOM_" ("_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,1)_")"
. ;display comment
. K ^UTILITY($J,"W") S X=PSCOM,DIWL=1,DIWR=78 D ^DIWP
. F PSL=1:1 Q:('$D(^UTILITY($J,"W",1,PSL,0))) D
. . S LAST=0 I '$D(^UTILITY($J,"W",1,PSL+1)),'$O(^PSRX(RX,"REJ",REJ,"COM",PSI),-1) S LAST=1
. . S TXTLN=$G(^UTILITY($J,"W",1,PSL,0))
. . D SETLN^PSOREJP1($S(PSL=1:"- ",1:" ")_TXTLN,0,$S(LAST:1,1:0),1)
K ^UTILITY($J,"W")
Q
;
ADDCOM ; - Add comment worklist action
N PSCOM
D FULL^VALM1
S PSCOM=$$COMMENT("Comment: ",150)
I $L(PSCOM)>0,PSCOM'["^" D
. D SAVECOM(RX,REJ,PSCOM) ;save the comment
. D INIT^PSOREJP1 ;update screen
S VALMBCK="R"
Q
;
;Enter a comment
;PSOTR -prompt string
;PSMLEN -maxlen
;returns:
; "^" - if user chose to quit
; "" - nothing entered or input has been discarded
; otherwise - comment's text
N DIR,DTOUT,DUOUT,PSQ
I '$D(PSOTR) S PSOTR="Comment "
I '$D(PSMLEN) S PSMLEN=150
S DIR(0)="FA^1:150"
S DIR("A")=PSOTR
S DIR("?")="Enter a free text comment up to 150 characters long."
S PSQ=0
F D Q:+PSQ'=0
. W ! D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S PSQ=-1 Q
. I $L(Y)'>PSMLEN S PSQ=1 Q
. W !!,"Enter a free text comment up to 150 characters long.",!
. S DIR("B")=$E(Y,1,PSMLEN)
Q:PSQ<0 "^"
Q:$L(Y)=0 ""
S PSQ=$$YESNO("Confirm","YES")
I PSQ=-1 Q "^"
I PSQ=0 Q ""
Q Y
;
; Ask
; Input:
; PSQSTR - question
; PSDFL - default answer
; Output:
; 1 YES
; 0 NO
; -1 if cancelled
YESNO(PSQSTR,PSDFL) ; Default - YES
N DIR,Y,DUOUT
S DIR(0)="Y"
S DIR("A")=PSQSTR
S:$L($G(PSDFL)) DIR("B")=PSDFL
W ! D ^DIR
Q $S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
;
;Save comment
SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ;
N PSREC,PSDA,PSERR
I '$G(DATETIME) D NOW^%DTC S DATETIME=%
I '$G(USER) S USER=DUZ
D INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME)
S PSREC=$O(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0))
I PSREC>0 D
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$G(PSCOMNT)
. D FILE^DIE("","PSDA","PSERR")
Q
;
;/**
;PSSFILE - subfile# (52.2551) for comment
;PSIEN - ien for file in which the new subfile entry will be inserted
;PSVAL01 - .01 value for the new entry
INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/
N PSSSI,PSIENS,PSFDA,PSER
S PSIENS="+1,"_PSIEN1_","_PSIEN0_","
S PSFDA(PSSFILE,PSIENS,.01)=PSVAL01
D UPDATE^DIE("","PSFDA","PSSSI","PSER")
I $D(PSER) D BMES^XPDUTL(PSER("DIERR",1,"TEXT",1))
Q
;
PRINT(RX,RFL) ; Print Label for specific Rx/Fill
N PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG
N POP,DFN,PDUZ,RXFL,REPRINT,REJLBL
S REJLBL=0 F S REJLBL=$O(^PSRX(RX,"L",REJLBL)) Q:'REJLBL I +$$GET1^DIQ(52.032,REJLBL_","_RX,1,"I")=RFL S REPRINT=1 Q
;
S PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=^PS(59,PSOSITE,1)
S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1))
S PPL=RX I RFL S RXFL(RX)=RFL
W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q
;
S IOP=PSOLAP D ^%ZIS,DQ^PSOLBL,^%ZISC
Q
;
RXINFO(RX,FILL,LINE) ; Returns header displayable Rx Information
N TXT,RXINFO,LBL,CMOP,DRG
I LINE=1 D
. S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
. S $E(RXINFO,30)="ECME#: "_$E(10000000+RX,2,8)
. S $E(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL))
I LINE=2 D
. S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0)
. S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43)
. S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
Q $G(RXINFO)
;
SEND(COD1,COD2,COD3,CLA,PA) ; - Sends Claim to ECME and closes Reject
N DIR,OVRC,RESP,ALTXT,COM
S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES"
S DIR("A",1)=" When you confirm, a new claim will be submitted for"
S DIR("A",2)=" the prescription and this REJECT will be marked"
S DIR("A",3)=" resolved."
S DIR("A",4)=" "
W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
I $G(COD1)'="" S OVRC=$G(COD2)_"^"_$G(COD1)_"^"_$G(COD3)
S ALTXT="REJECT WORKLIST"
S:$G(OVRC)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")"
S:$G(CLA) ALTXT=ALTXT_"(CLARIF. CODE="_$P(CLA,"^",2)_")"
S:$G(PA) ALTXT=ALTXT_"(PRIOR AUTH.="_$TR(PA,"^","/")_")"
D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRC),,.RESP,,ALTXT,$G(CLA),$G(PA))
I $G(RESP) D Q
. W !!?10,"Claim could not be submitted. Please try again later!"
. W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2
;
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
;
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
I $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC) D
. Q:$$STATUS^PSOBPSUT(RX,RFL)'["PAYABLE"
. N XXX S XXX=""
. W !,"This prescription can be pulled early from suspense or the label will print"
. W !,"when PRINT FROM SUSPENSE occurs.",!
. R !,"Press enter to continue... ",XXX:60
;
I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
Q
;
FILL ;Fill payable TRICARE Rx
N COM,OPNREJ,OPNREJ2,OPNREJ3
D FULL^VALM1
I $$CLOSED^PSOREJP1(RX,REJ) D Q
. S VALMSG="This Reject is marked resolved!",VALMBCK="R"
I $$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE" S VALMSG="Only Rxs with an E PAYABLE status may be filled.",VALMBCK="R" Q
S COM="AUTOMATICALLY CLOSED"
S (OPNREJ,OPNREJ2,OPNREJ3)=""
S OPNREJ2=0 F S OPNREJ2=$O(^PSRX(RX,"REJ",OPNREJ2)) Q:OPNREJ2=""!(OPNREJ2'?1N.N) S OPNREJ=OPNREJ_","_OPNREJ2
S OPNREJ=$E(OPNREJ,2,999),OPNREJ2=""
W !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":"
F I=1:1 S OPNREJ2=$P(OPNREJ,",",I) Q:OPNREJ2="" D
. S OPNREJ3="",OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01")
. W !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..."
. D CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,1,COM) W "OK]",!,$C(7) H 1
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
S VALMBCK="R",CHANGE=1
Q
;
DC ;Discontinue TRICARE Rx
N ACTION S ACTION="D"
D FULL^VALM1
S ACTION=$$DC^PSOREJU1(RX,ACTION)
I ACTION="Q"!(ACTION="^")!('$G(PSORX("DFLG"))) S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q
S CHANGE=1
Q
;
PSOREJP3 ;ALB/SS - Third Party Reject Display Screen - Comments ;10/27/06
+1 ;;7.0;OUTPATIENT PHARMACY;**260,287,289**;DEC 1997;Build 107
+2 ;
COM ; Builds the Comments section in the Reject Display Screen
+1 IF +$ORDER(^PSRX(RX,"REJ",REJ,"COM",0))=0
QUIT
+2 DO SETLN^PSOREJP1()
+3 DO SETLN^PSOREJP1("COMMENTS",1,1)
+4 NEW DIWL,DIWR,LNCNT,MAXLN,PSL
+5 NEW I,X,PSI,Y,LAST,PSOCOM,TXTLN
+6 SET PSI=999999
+7 FOR
SET PSI=$ORDER(^PSRX(RX,"REJ",REJ,"COM",PSI),-1)
IF +PSI=0
QUIT
Begin DoDot:1
+8 SET PSCOM=$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,.01)_" - "
+9 SET PSCOM=PSCOM_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,2)
+10 SET PSCOM=PSCOM_" ("_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,1)_")"
+11 ;display comment
+12 KILL ^UTILITY($JOB,"W")
SET X=PSCOM
SET DIWL=1
SET DIWR=78
DO ^DIWP
+13 FOR PSL=1:1
IF ('$DATA(^UTILITY($JOB,"W",1,PSL,0)))
QUIT
Begin DoDot:2
+14 SET LAST=0
IF '$DATA(^UTILITY($JOB,"W",1,PSL+1))
IF '$ORDER(^PSRX(RX,"REJ",REJ,"COM",PSI),-1)
SET LAST=1
+15 SET TXTLN=$GET(^UTILITY($JOB,"W",1,PSL,0))
+16 DO SETLN^PSOREJP1($SELECT(PSL=1:"- ",1:" ")_TXTLN,0,$SELECT(LAST:1,1:0),1)
End DoDot:2
End DoDot:1
+17 KILL ^UTILITY($JOB,"W")
+18 QUIT
+19 ;
ADDCOM ; - Add comment worklist action
+1 NEW PSCOM
+2 DO FULL^VALM1
+3 SET PSCOM=$$COMMENT("Comment: ",150)
+4 IF $LENGTH(PSCOM)>0
IF PSCOM'["^"
Begin DoDot:1
+5 ;save the comment
DO SAVECOM(RX,REJ,PSCOM)
+6 ;update screen
DO INIT^PSOREJP1
End DoDot:1
+7 SET VALMBCK="R"
+8 QUIT
+9 ;
+10 ;Enter a comment
+11 ;PSOTR -prompt string
+12 ;PSMLEN -maxlen
+13 ;returns:
+14 ; "^" - if user chose to quit
+15 ; "" - nothing entered or input has been discarded
+16 ; otherwise - comment's text
+1 NEW DIR,DTOUT,DUOUT,PSQ
+2 IF '$DATA(PSOTR)
SET PSOTR="Comment "
+3 IF '$DATA(PSMLEN)
SET PSMLEN=150
+4 SET DIR(0)="FA^1:150"
+5 SET DIR("A")=PSOTR
+6 SET DIR("?")="Enter a free text comment up to 150 characters long."
+7 SET PSQ=0
+8 FOR
Begin DoDot:1
+9 WRITE !
DO ^DIR
+10 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSQ=-1
QUIT
+11 IF $LENGTH(Y)'>PSMLEN
SET PSQ=1
QUIT
+12 WRITE !!,"Enter a free text comment up to 150 characters long.",!
+13 SET DIR("B")=$EXTRACT(Y,1,PSMLEN)
End DoDot:1
IF +PSQ'=0
QUIT
+14 IF PSQ<0
QUIT "^"
+15 IF $LENGTH(Y)=0
QUIT ""
+16 SET PSQ=$$YESNO("Confirm","YES")
+17 IF PSQ=-1
QUIT "^"
+18 IF PSQ=0
QUIT ""
+19 QUIT Y
+20 ;
+21 ; Ask
+22 ; Input:
+23 ; PSQSTR - question
+24 ; PSDFL - default answer
+25 ; Output:
+26 ; 1 YES
+27 ; 0 NO
+28 ; -1 if cancelled
YESNO(PSQSTR,PSDFL) ; Default - YES
+1 NEW DIR,Y,DUOUT
+2 SET DIR(0)="Y"
+3 SET DIR("A")=PSQSTR
+4 IF $LENGTH($GET(PSDFL))
SET DIR("B")=PSDFL
+5 WRITE !
DO ^DIR
+6 QUIT $SELECT($GET(DUOUT)!$GET(DUOUT)!(Y="^"):-1,1:Y)
+7 ;
+8 ;Save comment
SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ;
+1 NEW PSREC,PSDA,PSERR
+2 IF '$GET(DATETIME)
DO NOW^%DTC
SET DATETIME=%
+3 IF '$GET(USER)
SET USER=DUZ
+4 DO INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME)
+5 SET PSREC=$ORDER(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0))
+6 IF PSREC>0
Begin DoDot:1
+7 SET PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER
+8 SET PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$GET(PSCOMNT)
+9 DO FILE^DIE("","PSDA","PSERR")
End DoDot:1
+10 QUIT
+11 ;
+12 ;/**
+13 ;PSSFILE - subfile# (52.2551) for comment
+14 ;PSIEN - ien for file in which the new subfile entry will be inserted
+15 ;PSVAL01 - .01 value for the new entry
INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/
+1 NEW PSSSI,PSIENS,PSFDA,PSER
+2 SET PSIENS="+1,"_PSIEN1_","_PSIEN0_","
+3 SET PSFDA(PSSFILE,PSIENS,.01)=PSVAL01
+4 DO UPDATE^DIE("","PSFDA","PSSSI","PSER")
+5 IF $DATA(PSER)
DO BMES^XPDUTL(PSER("DIERR",1,"TEXT",1))
+6 QUIT
+7 ;
PRINT(RX,RFL) ; Print Label for specific Rx/Fill
+1 NEW PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG
+2 NEW POP,DFN,PDUZ,RXFL,REPRINT,REJLBL
+3 SET REJLBL=0
FOR
SET REJLBL=$ORDER(^PSRX(RX,"L",REJLBL))
IF 'REJLBL
QUIT
IF +$$GET1^DIQ(52.032,REJLBL_","_RX,1,"I")=RFL
SET REPRINT=1
QUIT
+4 ;
+5 SET PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL)
SET PSOPAR=^PS(59,PSOSITE,1)
+6 SET DFN=$$GET1^DIQ(52,RX,2,"I")
SET PDUZ=DUZ
SET PSOSYS=$GET(^PS(59.7,1,40.1))
+7 SET PPL=RX
IF RFL
SET RXFL(RX)=RFL
+8 WRITE !
SET PSOBFLAG=1
DO LBL^PSOLSET
IF $GET(PSOQUIT)
QUIT
+9 ;
+10 SET IOP=PSOLAP
DO ^%ZIS
DO DQ^PSOLBL
DO ^%ZISC
+11 QUIT
+12 ;
RXINFO(RX,FILL,LINE) ; Returns header displayable Rx Information
+1 NEW TXT,RXINFO,LBL,CMOP,DRG
+2 IF LINE=1
Begin DoDot:1
+3 SET RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
+4 SET $EXTRACT(RXINFO,30)="ECME#: "_$EXTRACT(10000000+RX,2,8)
+5 SET $EXTRACT(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL))
End DoDot:1
+6 IF LINE=2
Begin DoDot:1
+7 SET DRG=$$GET1^DIQ(52,RX,6,"I")
SET CMOP=$SELECT($DATA(^PSDRUG("AQ",DRG)):1,1:0)
+8 SET RXINFO=$SELECT(CMOP:"CMOP ",1:"")_"Drug"
SET $EXTRACT(RXINFO,10)=": "_$EXTRACT($$GET1^DIQ(52,RX,6),1,43)
+9 SET $EXTRACT(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
End DoDot:1
+10 QUIT $GET(RXINFO)
+11 ;
SEND(COD1,COD2,COD3,CLA,PA) ; - Sends Claim to ECME and closes Reject
+1 NEW DIR,OVRC,RESP,ALTXT,COM
+2 SET DIR(0)="Y"
SET DIR("A")=" Confirm"
SET DIR("B")="YES"
+3 SET DIR("A",1)=" When you confirm, a new claim will be submitted for"
+4 SET DIR("A",2)=" the prescription and this REJECT will be marked"
+5 SET DIR("A",3)=" resolved."
+6 SET DIR("A",4)=" "
+7 WRITE !
DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+8 IF $GET(COD1)'=""
SET OVRC=$GET(COD2)_"^"_$GET(COD1)_"^"_$GET(COD3)
+9 SET ALTXT="REJECT WORKLIST"
+10 IF $GET(OVRC)'=""
SET ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$GET(COD1)_"/"_$GET(COD2)_"/"_$GET(COD3)_")"
+11 IF $GET(CLA)
SET ALTXT=ALTXT_"(CLARIF. CODE="_$PIECE(CLA,"^",2)_")"
+12 IF $GET(PA)
SET ALTXT=ALTXT_"(PRIOR AUTH.="_$TRANSLATE(PA,"^","/")_")"
+13 DO ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$GET(OVRC),,.RESP,,ALTXT,$GET(CLA),$GET(PA))
+14 IF $GET(RESP)
Begin DoDot:1
+15 WRITE !!?10,"Claim could not be submitted. Please try again later!"
+16 WRITE !,?10,"Reason: ",$SELECT($PIECE(RESP,"^",2)="":"UNKNOWN",1:$PIECE(RESP,"^",2)),$CHAR(7)
HANG 2
End DoDot:1
QUIT
+17 ;
+18 IF $$PTLBL^PSOREJP2(RX,FILL)
DO PRINT(RX,FILL)
+19 ;
+20 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
+21 IF $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC)
Begin DoDot:1
+22 IF $$STATUS^PSOBPSUT(RX,RFL)'["PAYABLE"
QUIT
+23 NEW XXX
SET XXX=""
+24 WRITE !,"This prescription can be pulled early from suspense or the label will print"
+25 WRITE !,"when PRINT FROM SUSPENSE occurs.",!
+26 READ !,"Press enter to continue... ",XXX:60
End DoDot:1
+27 ;
+28 IF $DATA(PSOSTFLT)
IF PSOSTFLT'="B"
SET CHANGE=1
+29 QUIT
+30 ;
FILL ;Fill payable TRICARE Rx
+1 NEW COM,OPNREJ,OPNREJ2,OPNREJ3
+2 DO FULL^VALM1
+3 IF $$CLOSED^PSOREJP1(RX,REJ)
Begin DoDot:1
+4 SET VALMSG="This Reject is marked resolved!"
SET VALMBCK="R"
End DoDot:1
QUIT
+5 IF $$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE"
SET VALMSG="Only Rxs with an E PAYABLE status may be filled."
SET VALMBCK="R"
QUIT
+6 SET COM="AUTOMATICALLY CLOSED"
+7 SET (OPNREJ,OPNREJ2,OPNREJ3)=""
+8 SET OPNREJ2=0
FOR
SET OPNREJ2=$ORDER(^PSRX(RX,"REJ",OPNREJ2))
IF OPNREJ2=""!(OPNREJ2'?1N.N)
QUIT
SET OPNREJ=OPNREJ_","_OPNREJ2
+9 SET OPNREJ=$EXTRACT(OPNREJ,2,999)
SET OPNREJ2=""
+10 WRITE !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":"
+11 FOR I=1:1
SET OPNREJ2=$PIECE(OPNREJ,",",I)
IF OPNREJ2=""
QUIT
Begin DoDot:1
+12 SET OPNREJ3=""
SET OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01")
+13 WRITE !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..."
+14 DO CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,1,COM)
WRITE "OK]",!,$CHAR(7)
HANG 1
End DoDot:1
+15 IF $$PTLBL^PSOREJP2(RX,FILL)
DO PRINT(RX,FILL)
+16 SET VALMBCK="R"
SET CHANGE=1
+17 QUIT
+18 ;
DC ;Discontinue TRICARE Rx
+1 NEW ACTION
SET ACTION="D"
+2 DO FULL^VALM1
+3 SET ACTION=$$DC^PSOREJU1(RX,ACTION)
+4 IF ACTION="Q"!(ACTION="^")!('$GET(PSORX("DFLG")))
SET VALMSG="NO ACTION TAKEN."
SET VALMBCK="R"
QUIT
+5 SET CHANGE=1
+6 QUIT
+7 ;
