Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOREJP3

PSOREJP3.m

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