PSORRX1 ;AITC/BWF - Remote RX driver ;8/30/16 12:00am
;;7.0;OUTPATIENT PHARMACY;**454,499,509,519,532,594,643,736,740,774**;DEC 1997;Build 15
;
;Reference ^PSDRUG( supported by DBIA 221
;Reference ^PSNDF supported by DBIA 2195
Q
;
REMOTERX(DFN,PSOSITE) ;
N RXRES,MSG,HLARR,CNT,RXDAT,HLARR,HLPROT,DONE,ORFS,ORCS,ORRS,ORES,ORSS,ORQUIT,HLQUIT,HLDAT,TFLIST,HLP,HLNODE,HLNEXT,HLINSTN
N PID1,PID4,PID5,PID6,TFDAT,LOOP,RXMSG,PSORRDAT,PSOHCNT,ERR,HL,PSORRDAT,ORERR,SITE
S HLARR=$NA(^TMP("HLS",$J)) K @HLARR
S HLDAT=$NA(^XTMP("PSORRX1",$J)) K @HLDAT
I 'DFN Q
S SITE=$P($$SITE^VASITE(),U)
S TFSTRING=$$GET1^DIQ(2,DFN,991.01,"I")_"^^^USVHA^NI^"_SITE
S HLPROT="PSO REMOTE RX QBP-Q13 EVENT"
D INIT^HLFNC2(HLPROT,.HL)
D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
I $D(ERR) W !,"There was a problem creating the PID segment for this patient.",!,"Please contact technical support.",!
S @HLARR@(1)="QPD^Q13~Active Prescriptions~HL70471^"
S DONE=0
F PSOHCNT=1:1 D Q:DONE
.I '$D(PSORRDAT(PSOHCNT)) S DONE=1 Q
.S @HLARR@(2)=$G(@HLARR@(2))_PSORRDAT(PSOHCNT)
S @HLARR@(3)="RCP^I"
S HLP("SUBSCRIBER")="^^^^200OneVA-HCHS-PSF" ;pso*7*736
D DIRECT^HLMA(HLPROT,"GM",1,.RXDAT,"",.HLP)
S ORFS="^",ORCS=$E($G(HL("ECH")),1),ORRS=$E($G(HL("ECH")),2),ORES=$E($G(HL("ECH")),3),ORSS=$E($G(HL("ECH")),4)
S HLQUIT=0,ORQUIT="",ORERR=""
I ($P(RXDAT,"^",2)]"")!($P(RXDAT,"^",3)]"") D Q
.W !,"The system is down or not responding"_$S($P(RXDAT,"^",3)]"":" ("_$P(RXDAT,"^",3)_").",1:".")
.W !,"Could not query prescriptions at other VA Pharmacy locations.",!
.K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR
F X HLNEXT Q:HLQUIT'>0!(ORQUIT'="") D
.N LOOP
.S LOOP=0 F S LOOP=$O(HLNODE(LOOP)) Q:LOOP="" S HLNODE=HLNODE_HLNODE(LOOP)
.I $E(HLNODE,1,3)="MSA"&(($P(HLNODE,ORFS,2)'="CA")) D LOGERR(DFN,.HLNODE,.HLDAT,$P(HLNODE,ORFS,4)) S ORQUIT=$P(HLNODE,ORFS,4)
.I $E(HLNODE,1,3)="ERR" D LOGERR(DFN,.HLNODE,.HLDAT) S ORQUIT=$P(HLNODE,ORFS,4)
.I $E(HLNODE,1,3)="RDT" D
..S @HLDAT@(0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
..D RXPRSE(DFN,.HLNODE,.HLDAT)
Q
LOGERR(DFN,DATA,HLDAT,NMSG) ;
N HLERR
S NMSG=$G(NMSG,"")
S HLERR=$S(NMSG'="":NMSG,1:$P(DATA,ORFS,9))
S:'$D(@HLDAT@(0)) @HLDAT@(0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
S @HLDAT@(DFN,"ERR")="<"_HLERR_">"
W !!,"When trying to query prescriptions at other VA Pharmacy",!,"Locations the following message was encountered:",!,"***",!,HLERR,!,"***",! K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
Q
; parse rx data from RDF segment
RXPRSE(DFN,DATA,HLDAT) ;
;RDF|14|Site Number~Rx Number~Drug Name~Quantity~Refills~Days Supply~Expiration Date
;~Issue Date~Stop Date~Last Fill Date~Sig~Detail~Status~VA Product IEN
N RXSITE,RXNUM,DNAME,QTY,REFILLS,DSUPP,EXPDT,ISSDATE,STOPDT,LFDT,SIG,DETAIL,STAT,STATNM,STATERR,DDONE,I,VAPIEN,DAT,PARK ; 774 removed VAFQDN (obsolete)
; p736 - removed code to handle overflow nodes as value is already passed in the correct format
S RXSITE=$P(DATA,ORFS,2),RXNUM=$P(DATA,ORFS,3),DNAME=$P(DATA,ORFS,4),QTY=$P(DATA,ORFS,5)
Q:DNAME=""
S REFILLS=$P(DATA,ORFS,6),DSUPP=$P(DATA,ORFS,7),EXPDT=$P(DATA,ORFS,8),ISSDATE=$P(DATA,ORFS,9)
S STOPDT=$P(DATA,ORFS,10),LFDT=$P(DATA,ORFS,11),SIG=$P(DATA,ORFS,12),DETAIL=$P(DATA,ORFS,13)
S STAT=$P(DATA,ORFS,14) Q:STAT=""
; VA Product IEN
S VAPIEN=$P(DATA,ORFS,15)
S PARK=+$P(DATA,ORFS,17) ; 774
Q:STAT=""
Q:'RXSITE!('RXNUM)
S @HLDAT@(DFN,RXSITE,STAT,DNAME,0)=RXNUM_U_QTY_U_REFILLS_U_DSUPP_U_EXPDT_U_ISSDATE_U_STOPDT_U_LFDT_U_STAT_U_VAPIEN_U_DNAME ; 774 removed VAFQDN
S @HLDAT@(DFN,RXSITE,STAT,DNAME,"SIG")=SIG
S @HLDAT@(DFN,RXSITE,STAT,DNAME,"DETAIL")=DETAIL
S @HLDAT@(DFN,RXSITE,STAT,DNAME,"PARK")=$S($G(PARK):1,1:0) ; 774
Q
; build and send refill request
REFREQ ;
N PHARM,PHONE,LOCSITE,DSUPP,MW,FILLDT,MSG,RXNUM,HLSTR,REMSITE,PHARMLN,PHARMFN,PHARMMI,TFSTRING,HLPROT,LOCDRUG,REMDRUG
N ORFS,ORCS,ORRS,ORES,ORSS,HLQUIT,ORQUIT,RESP,RETDFN,VAPIEN,DONE,PSORRDAT,PSOHCNT,DONE,HL,CSVAL,DIR,REMSIEN,PSOHLNK,PSOLNKDN,DOMOVR,RMSDOM,PSOHLSV
S HLARR=$NA(^TMP("HLS",$J)) K @HLARR
S HLDAT=$NA(^XTMP("REFREQ^PSORRX1",$J)) K @HLDAT
S HLPROT="PSO REMOTE RX RDS-O13 EVENT"
S MW="W"
D FULL^VALM1
S LOCSITE=$$STA^XUAF4(DUZ(2))
S PHARM=$$GET1^DIQ(200,DUZ,.01,"E"),PHARMLN=$P(PHARM,","),PHARMFN=$P($P(PHARM,",",2)," "),PHARMMI=$P($P(PHARM,",",2)," ",2)
S PHONE=$$GET1^DIQ(200,DUZ,.132,"E")
S RXNUM=$P(PSOLST(ORN),U,2) I 'RXNUM S MSG(1)="Invalid Rx #. Please contact technical support." Q
I SRXSTAT'="ACTIVE" W !!,"Only 'ACTIVE' remote prescriptions may be refilled at this time." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
S REMSITE=$P(PSOLST(ORN),U,4) ;,REMSIEN=$O(^DIC(4,"D",REMSITE,0))
S REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)") Q:'REMSIEN
S PSOREF("DFLG")=""
S REMDRUG=$P(REMDATA,U,11),VAPID=$P(REMDATA,U,10)
I '$L(VAPID) W !!,"Missing VA Product IEN. Rx# ",RXNUM," cannot be refilled." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
S LOCDRUG=$$DRUGMTCH(REMDRUG,VAPID)
I $G(LOCDRUG)=-1 Q ; user entered no so no reason to prompt again
I '$G(LOCDRUG) W !,"Cannot refill Rx # ",RXNUM,"." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q ; 774 - Remove reference to Drug Match
; PSO 740
I '$$VALDRGINT^PSORRPA1(LOCDRUG,"R",RXNUM) S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
; if we got this far, fill is most likely happening and remote
; worklist needs to be rebuilt when returning, so set flag.
S PSORRBLD=1
;
S (FILLDT,PSOREF("FILL DATE"))=DT
D INIT^HLFNC2(HLPROT,.HL)
D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
S DONE=0
F PSOHCNT=1:1 D Q:DONE
.I '$D(PSORRDAT(PSOHCNT)) S DONE=1 Q
.S @HLARR@(1)=$G(@HLARR@(1))_PSORRDAT(PSOHCNT)
;S @HLARR@(2)="ORC^RF^"_RXNUM_"~"_REMSITE_"~"_$$GET1^DIQ(4,REMSIEN,60,"E")_"^^^^^^^"_FILLDT_U_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
S @HLARR@(2)="ORC^RF^"_RXNUM_"~"_REMSITE_"~"_$$FQDN^PSORWRAP(,REMSIEN)_"^^^^^^^"_FILLDT_U_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
S @HLARR@(3)="RXO^^^^^^^^"_MW_"~"_$$OPAI_"~~"_LOCSITE
W !!,"Processing refill request. Please be patient as it may take a moment"
W !,"for the host site to respond and generate your label data...",!
S RMSDOM=$$FQDN^PSORWRAP(,REMSIEN)
S DOMOVR=REMSITE_"~"_RMSDOM_"~DNS"
S HLP("SUBSCRIBER")="^^^^"_DOMOVR
D DIRECT^HLMA(HLPROT,"GM",1,.RESP,"",.HLP)
D READMSG^PSORRX2(.HLDAT,"RF",LOCDRUG)
K @HLDAT,@HLARR
Q
; build and send partial fill request
PARTIAL() ;
N DIR,DONE,I,PRMPDAT,VAR,PRXNUM,PHARM,PHARMLN,PHARMFN,PHARMMI,PHONE,RXNUM,HLPROT,TFSTRING,HLARR,PHONE,REMSITE,HLDAT,LOCDRUG,EXIT,VAPIEN,HL,ERR
N PSOHCNT,DONE,PSORRDAT,CSVAL,REMSIEN,PSOHLNK,PSOLNKDN,REMDRUG,Y,EXE,DOMOVR,RMSDOM,PSOHLSV,VAPID
S HLPROT="PSO REMOTE RX RDS-O13 EVENT"
S HLDAT=$NA(^XTMP("PARTIAL^PSORRX1",$J)) K @HLDAT
S HLARR=$NA(^TMP("HLS",$J)) K @HLARR
D FULL^VALM1
I SRXSTAT'="ACTIVE" W !!,"Only 'ACTIVE' remote prescriptions may be actioned at this time." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
S LOCSITE=$$STA^XUAF4(DUZ(2))
S PHONE=$$GET1^DIQ(200,DUZ,.132,"E")
S PRXNUM=$P(PSOLST(ORN),U,2) I 'PRXNUM S MSG(1)="Invalid Rx #. Please contact technical support." Q
S REMSITE=$P(PSOLST(ORN),U,4)
S REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)") Q:'REMSIEN
S DONE=0,CNT=1
; prompt for fields that would normally be prompted for a local partial fill.
D FULL^VALM1
S REMDRUG=$P(REMDATA,U,11),VAPID=$P(REMDATA,U,10)
I '$L(VAPID) W !,"Missing VA Product ID. Rx# ",PRXNUM," cannot process a partial fill." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
S LOCDRUG=$$DRUGMTCH(REMDRUG,VAPID)
I $G(LOCDRUG)=-1 Q ; user entered no so no reason to prompt again
I '$G(LOCDRUG) W !,"Cannot process a partial fill for Rx # ",PRXNUM,"." S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q ; 774 - Remove reference to Drug Match
; PSO 740
I '$$VALDRGINT^PSORRPA1(LOCDRUG,"P",PRXNUM) S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
; if we got this far, fill is most likely happening and remote
; worklist needs to be rebuilt when returning, so set flag.
S PSORRBLD=1
S EXIT=0
S PDATE=DT
S MW="W"
F I=1:1 D Q:DONE!(EXIT)
.S PRMPDAT=$T(PRMPTXT+I)
.S PRMPDAT=$P(PRMPDAT,";;",2)
.I PRMPDAT="Q" S DONE=1 Q
.K DIR
.S DIR(0)=$P(PRMPDAT,"|"),DIR("A")=$P(PRMPDAT,"|",2),VAR=$P(PRMPDAT,"|",4) S:$L($P(PRMPDAT,"|",3)) DIR("B")=$P(PRMPDAT,"|",3)
.I $G(DIR("B"))["~" D
..S EXE=$TR(DIR("B"),"~","^") X EXE S DIR("B")=DEF
.D ^DIR
.I Y="^" S EXIT=1 Q
.S @VAR=$S($P(DIR(0),"^")["P":$P(Y,U,2),1:Y) ;*499
K DEF
I EXIT W !,"Cancelling partial fill request.",! K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
; if we got this far, fill attempt is happening and remote worklist
; needs to be rebuilt when returning, so set flag.
S PSORRBLD=1
S PHARMLN=$P(PHARM,","),PHARMFN=$P($P(PHARM,",",2)," "),PHARMMI=$P($P(PHARM,",",2)," ",2)
D INIT^HLFNC2(HLPROT,.HL)
D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
S DONE=0
F PSOHCNT=1:1 D Q:DONE
.I '$D(PSORRDAT(PSOHCNT)) S DONE=1 Q
.S @HLARR@(1)=$G(@HLARR@(1))_PSORRDAT(PSOHCNT)
S @HLARR@(2)="ORC^PF^"_PRXNUM_"~"_REMSITE_"~"_$$FQDN^PSORWRAP(,REMSIEN)_"^^^^^^^"_PDATE_"^"_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
S @HLARR@(3)="RXO^1^"_QTY_"^^^^^^"_MW_"~"_$$OPAI_"~~"_LOCSITE_"^^^"_DSUPP
S @HLARR@(4)="NTE^1^L^"_REMARKS
W !!,"Processing partial fill request. Please be patient as it may take a moment"
W !,"for the host site to respond and generate your label data...",!
S RMSDOM=$$FQDN^PSORWRAP(,REMSIEN)
S DOMOVR=REMSITE_"~"_RMSDOM_"~DNS"
S HLP("SUBSCRIBER")="^^^^"_DOMOVR
D DIRECT^HLMA(HLPROT,"GM",1,.HL,"",.HLP)
I $P(HL,U,2) D Q
. W !,"An error was encountered when trying to process the results",!,"from the refill/partial fill request.",!!,$P(HL,U,3)
. K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR
. D CL
; clean up variables used
D READMSG^PSORRX2(.HLDAT,"PR",LOCDRUG)
CL ;
K PDATE,QTY,DSUPP,PHARM,REMARKS,MW
K @HLDAT,@HLARR
Q
;
DRUGMTCH(DRGNM,VAPIN) ;p736 - VAPIEN directly passed into DRUGMTCH
; returns -1 if a match was found but user said NO
;
I $G(DRGNM)']"" Q "" ; p736 - ensures DRGNM is valid
;
N LDIEN,MATCH,EXIT,DRL,VAGENER,FOUND,CHECK,DIC,DRGARY,LDNAME,Y,VAPSTR,MTCHSTR,DRLCNT
N DRGNM2,MTCHSTR,DRLCNT,DRSV,CSSCH,VAPIDSTR,VAPIEN,CSPROD,VAPIENCNT,DINACT
S (CHECK,VAPSTR)="",(DRLCNT,DRSV)=0,CSPROD=0,DINACT=""
I +$G(VAPIN) S VAPSTR=$$GET1^DIQ(50.68,+$G(VAPIN),2,"E")
S VAPIDSTR=$$GET1^DIQ(50.68,+$G(VAPIN),6,"E")
W !!,"Remote site drug name: "_$G(DRGNM)
I $L(VAPIDSTR) S VAPIEN=0 F S VAPIEN=$O(^PSNDF(50.68,"C",VAPIDSTR,VAPIEN)) Q:'VAPIEN D
. S CSSCH=$$GET1^DIQ(50.68,VAPIEN,19,"I")
. I '$G(CSPROD),(+CSSCH>0),(+CSSCH<6) D Q
. . S CSPROD=1
. . W !!,"VA Product ID: ",VAPIDSTR," CS FEDERAL SCHEDULE: ",+CSSCH
. . W !!,"Controlled substances are not allowed for ONEVA Pharmacy dispensing.",!
. . D PAUSE^VALM1
. S VAPIEN(VAPIEN)=VAPSTR
;
I CSPROD=1 Q 0
I '$D(VAPIEN(VAPIN)) W !!,"Remote site VA PRODUCT IDENTIFIER: "_VAPIDSTR_" *** NOT FOUND ***",!
;
; Look for drug name
I $D(^PSDRUG("B",DRGNM)) D
. S LDIEN=0 F S LDIEN=$O(^PSDRUG("B",DRGNM,LDIEN)) Q:'LDIEN D
. . S VAPIEN=""
. . ; Filter out inactive, not on outpatient formulary, not Pharmacy orderable, not linked to VAPIDSTR, CS
. . I $$GET1^DIQ(50,LDIEN,63,"I")'["O" Q
. . I $$GET1^DIQ(50,LDIEN,2.1,"I")="" Q
. . S DINACT=$$GET1^DIQ(50,LDIEN,100,"I")
. . I (DINACT>0),($$DT^XLFDT>DINACT) Q
. . S VAPIEN=$$GET1^DIQ(50,LDIEN,22,"I") I VAPIEN="" Q ; 740
. . I $$GET1^DIQ(50,LDIEN,3) I $$GET1^DIQ(50,LDIEN,3)>0&($$GET1^DIQ(50,LDIEN,3)<6) Q
. . I '$D(DRGARY(LDIEN)) S DRGARY(LDIEN)="",DRLCNT=DRLCNT+1
;
; Quit if drug matched name and user accepted
I DRLCNT=1 D I CHECK Q LDIEN
. S LDIEN=$O(DRGARY(0))
. S DRSV=LDIEN ;Save single match to filter from displaying from local drug
. S LDNAME=$$GET1^DIQ(50,LDIEN,.01,"E")
. W !,"Matching Drug Found for Dispensing: "_LDNAME
. S CHECK=$$DIR
;
I DRLCNT=0 W !,"No active drug name match found for "_DRGNM_"."
;
S CHECK="",DRLCNT=0 K DRGARY
S VAPIEN=0 F S VAPIEN=$O(VAPIEN(VAPIEN)) Q:'VAPIEN D
. S VAPSTR=$$GET1^DIQ(50.68,VAPIEN,2,"E")
. ;Loop thru the APR index in 50
. S LDIEN=0 F S LDIEN=$O(^PSDRUG("APR",VAPIEN,LDIEN)) Q:'LDIEN D
. . ;filter out inactive, drugs not on outpatient formulary, not linked to Pharmacy orderable, 'CS
. . I $$GET1^DIQ(50,LDIEN,100,"I"),(DT'<$$GET1^DIQ(50,LDIEN,100,"I")) Q
. . I $$GET1^DIQ(50,LDIEN,63,"I")'["O" Q
. . I $$GET1^DIQ(50,LDIEN,2.1,"I")="" Q
. . I $$GET1^DIQ(50,LDIEN,3),$$GET1^DIQ(50,LDIEN,3)>0&($$GET1^DIQ(50,LDIEN,3)<6)
. . I '$D(DRGARY(LDIEN)) S DRGARY(LDIEN)=VAPSTR,DRLCNT=DRLCNT+1
;
;Filter out drug already presented
I DRSV,$D(DRGARY(DRSV)) K DRGARY(DRSV) S DRLCNT=DRLCNT-1
;
I DRLCNT D
. W !!,"Drugs matching the VA PRODUCT IDENTIFIER:"
. S (MATCH,EXIT)=0
. N PSODRGL,PSODRGLI,PSODRGL0,PSODRGID,PSODRGC S DIR(0)=""
. F PSODRGLI=0:0 S PSODRGLI=$O(DRGARY(PSODRGLI)) Q:'PSODRGLI D
. . S PSODRGL0=$G(^PSDRUG(PSODRGLI,0)),PSODRGID=$G(^PSDRUG(PSODRGLI,"I"))
. . Q:$TR(PSODRGL0,"^")="" S PSODRGC=$G(PSODRGC)+1
. .S DIR(0)=DIR(0)_$S(DIR(0)]"":";",1:"")
. .; Increased drug name length from 30 to 40 - PSO*7*594
. .S DIR(0)=DIR(0)_$G(PSODRGC)_":"_PSODRGLI_" "_$E($P(PSODRGL0,"^"),1,40)_" "_$J($P(PSODRGL0,"^",2),7)_" "_$S(PSODRGID:$E(PSODRGID,4,5)_"-"_$E(PSODRGID,6,7)_"-"_$E(PSODRGID,2,3)_" ",1:"")_$P(PSODRGL0,"^",10)
. .S DIR("L",PSODRGC)=PSODRGC_". "_PSODRGLI_" "_$E($P(PSODRGL0,"^"),1,40)_" "_$J($P(PSODRGL0,"^",2),7)_" "_$S(PSODRGID:$E(PSODRGID,4,5)_"-"_$E(PSODRGID,6,7)_"-"_$E(PSODRGID,2,3)_" ",1:"")_$P(PSODRGL0,"^",10)
. S DIR(0)="SO^"_DIR(0),DIR("L")="" ;1:$G(PSODRGC)"
. S DIR("A")="Select Drug from list ("_1_"-"_DRLCNT_") "_"or <enter> to quit processing."
. D ^DIR K DIR
. I +Y<1!($D(DUOUT))!($D(DTOUT)) S Y="",DRLCNT=0
. I Y>0 S LDIEN=+Y(0)
. I $G(LDIEN) K DIR S DIR(0)="Y",DIR("A")="Would you like to use this drug" D ^DIR
. I +Y<1!($D(DUOUT))!($D(DTOUT)) S DRLCNT=0 ;DRLCNT=0 causes Drug: to be prompted for
;
I DRLCNT,$G(Y) Q LDIEN ;a drug was accepted
;
;No VAPIEN, or no drug was selected or no drugs were found
K DIR
W !
W !,"No other local match could be found for "_DRGNM_"."
W !,"You may need to update your Drug file to process this order"
D PAUSE^VALM1
Q 0
;
; TEXT to build prompts
;;DIR(0)|DIR(A)|DIR(B)|VARIABLE
PRMPTXT ;
;;N^^I $D(X),X>$P(REMDATA,U,2) D EN^DDIOL("QTY CANNOT BE GREATER THAN THE ORIGINAL QTY OF "_$P(REMDATA,U,2)) K X|Enter Quantity||QTY
;;N|DAYS SUPPLY||DSUPP
;;P^200:QEAMZ|Select PHARMACIST Name|S DEF=$$GET1~DIQ(200,DUZ,.01,"E")|PHARM
;;F^0:60|REMARKS||REMARKS
;;Q
Q
DIR() ;
N DIR,Y
S DIR(0)="Y",DIR("B")="NO"
S DIR("A",1)="Would you like to use the system matched drug for this"
S DIR("A")="refill/partial fill"
D ^DIR
Q Y
POST ; post init for PSO*7*454
N LIEN,OPSITE,DOMAIN,VAL
; add TCP/IP address for EMI
S DOMAIN=$$FQDN^PSORWRAP(,DUZ(2))
S VAL="PSORRXSEND"
S LIEN=$$FIND1^DIC(870,,"B",.VAL) Q:'LIEN
S FDA(870,LIEN_",",.08)=DOMAIN
S FDA(870,LIEN_",",400.01)="vaaussoalebp2.aac.domain.ext" D FILE^DIE(,"FDA") K FDA
; turn off the OneVA Pharmacy flag for all outpatient sites.
S OPSITE=0 F S OPSITE=$O(^PS(59,OPSITE)) Q:'OPSITE D
.S FDA(59,OPSITE_",",3001)="" D FILE^DIE(,"FDA") K FDA
Q
;
OPAI() ; determine if drug will go through OPAI
N PSOOINT,PSOOMARK
I '$G(PSOSITE) Q 1 ;REMOVE THIS LINE ONCE YOU DETERMINE PSOSITE IS DEFINED FORM THE PROTOCOL
S PSOOINT=$P($G(^PS(59,PSOSITE,1)),"^",30),PSOOMARK=0
S:+$G(LOCDRUG) PSOOMARK=+$G(^PSDRUG(LOCDRUG,6))
I 'PSOOINT Q 0
I PSOOINT=1!(PSOOINT=2) Q 1
I PSOOMARK Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORRX1 16023 printed Sep 23, 2025@20:10:47 Page 2
PSORRX1 ;AITC/BWF - Remote RX driver ;8/30/16 12:00am
+1 ;;7.0;OUTPATIENT PHARMACY;**454,499,509,519,532,594,643,736,740,774**;DEC 1997;Build 15
+2 ;
+3 ;Reference ^PSDRUG( supported by DBIA 221
+4 ;Reference ^PSNDF supported by DBIA 2195
+5 QUIT
+6 ;
REMOTERX(DFN,PSOSITE) ;
+1 NEW RXRES,MSG,HLARR,CNT,RXDAT,HLARR,HLPROT,DONE,ORFS,ORCS,ORRS,ORES,ORSS,ORQUIT,HLQUIT,HLDAT,TFLIST,HLP,HLNODE,HLNEXT,HLINSTN
+2 NEW PID1,PID4,PID5,PID6,TFDAT,LOOP,RXMSG,PSORRDAT,PSOHCNT,ERR,HL,PSORRDAT,ORERR,SITE
+3 SET HLARR=$NAME(^TMP("HLS",$JOB))
KILL @HLARR
+4 SET HLDAT=$NAME(^XTMP("PSORRX1",$JOB))
KILL @HLDAT
+5 IF 'DFN
QUIT
+6 SET SITE=$PIECE($$SITE^VASITE(),U)
+7 SET TFSTRING=$$GET1^DIQ(2,DFN,991.01,"I")_"^^^USVHA^NI^"_SITE
+8 SET HLPROT="PSO REMOTE RX QBP-Q13 EVENT"
+9 DO INIT^HLFNC2(HLPROT,.HL)
+10 DO BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
+11 IF $DATA(ERR)
WRITE !,"There was a problem creating the PID segment for this patient.",!,"Please contact technical support.",!
+12 SET @HLARR@(1)="QPD^Q13~Active Prescriptions~HL70471^"
+13 SET DONE=0
+14 FOR PSOHCNT=1:1
Begin DoDot:1
+15 IF '$DATA(PSORRDAT(PSOHCNT))
SET DONE=1
QUIT
+16 SET @HLARR@(2)=$GET(@HLARR@(2))_PSORRDAT(PSOHCNT)
End DoDot:1
if DONE
QUIT
+17 SET @HLARR@(3)="RCP^I"
+18 ;pso*7*736
SET HLP("SUBSCRIBER")="^^^^200OneVA-HCHS-PSF"
+19 DO DIRECT^HLMA(HLPROT,"GM",1,.RXDAT,"",.HLP)
+20 SET ORFS="^"
SET ORCS=$EXTRACT($GET(HL("ECH")),1)
SET ORRS=$EXTRACT($GET(HL("ECH")),2)
SET ORES=$EXTRACT($GET(HL("ECH")),3)
SET ORSS=$EXTRACT($GET(HL("ECH")),4)
+21 SET HLQUIT=0
SET ORQUIT=""
SET ORERR=""
+22 IF ($PIECE(RXDAT,"^",2)]"")!($PIECE(RXDAT,"^",3)]"")
Begin DoDot:1
+23 WRITE !,"The system is down or not responding"_$SELECT($PIECE(RXDAT,"^",3)]"":" ("_$PIECE(RXDAT,"^",3)_").",1:".")
+24 WRITE !,"Could not query prescriptions at other VA Pharmacy locations.",!
+25 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
End DoDot:1
QUIT
+26 FOR
XECUTE HLNEXT
if HLQUIT'>0!(ORQUIT'="")
QUIT
Begin DoDot:1
+27 NEW LOOP
+28 SET LOOP=0
FOR
SET LOOP=$ORDER(HLNODE(LOOP))
if LOOP=""
QUIT
SET HLNODE=HLNODE_HLNODE(LOOP)
+29 IF $EXTRACT(HLNODE,1,3)="MSA"&(($PIECE(HLNODE,ORFS,2)'="CA"))
DO LOGERR(DFN,.HLNODE,.HLDAT,$PIECE(HLNODE,ORFS,4))
SET ORQUIT=$PIECE(HLNODE,ORFS,4)
+30 IF $EXTRACT(HLNODE,1,3)="ERR"
DO LOGERR(DFN,.HLNODE,.HLDAT)
SET ORQUIT=$PIECE(HLNODE,ORFS,4)
+31 IF $EXTRACT(HLNODE,1,3)="RDT"
Begin DoDot:2
+32 SET @HLDAT@(0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
+33 DO RXPRSE(DFN,.HLNODE,.HLDAT)
End DoDot:2
End DoDot:1
+34 QUIT
LOGERR(DFN,DATA,HLDAT,NMSG) ;
+1 NEW HLERR
+2 SET NMSG=$GET(NMSG,"")
+3 SET HLERR=$SELECT(NMSG'="":NMSG,1:$PIECE(DATA,ORFS,9))
+4 if '$DATA(@HLDAT@(0))
SET @HLDAT@(0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
+5 SET @HLDAT@(DFN,"ERR")="<"_HLERR_">"
+6 WRITE !!,"When trying to query prescriptions at other VA Pharmacy",!,"Locations the following message was encountered:",!,"***",!,HLERR,!,"***",!
KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+7 QUIT
+8 ; parse rx data from RDF segment
RXPRSE(DFN,DATA,HLDAT) ;
+1 ;RDF|14|Site Number~Rx Number~Drug Name~Quantity~Refills~Days Supply~Expiration Date
+2 ;~Issue Date~Stop Date~Last Fill Date~Sig~Detail~Status~VA Product IEN
+3 ; 774 removed VAFQDN (obsolete)
NEW RXSITE,RXNUM,DNAME,QTY,REFILLS,DSUPP,EXPDT,ISSDATE,STOPDT,LFDT,SIG,DETAIL,STAT,STATNM,STATERR,DDONE,I,VAPIEN,DAT,PARK
+4 ; p736 - removed code to handle overflow nodes as value is already passed in the correct format
+5 SET RXSITE=$PIECE(DATA,ORFS,2)
SET RXNUM=$PIECE(DATA,ORFS,3)
SET DNAME=$PIECE(DATA,ORFS,4)
SET QTY=$PIECE(DATA,ORFS,5)
+6 if DNAME=""
QUIT
+7 SET REFILLS=$PIECE(DATA,ORFS,6)
SET DSUPP=$PIECE(DATA,ORFS,7)
SET EXPDT=$PIECE(DATA,ORFS,8)
SET ISSDATE=$PIECE(DATA,ORFS,9)
+8 SET STOPDT=$PIECE(DATA,ORFS,10)
SET LFDT=$PIECE(DATA,ORFS,11)
SET SIG=$PIECE(DATA,ORFS,12)
SET DETAIL=$PIECE(DATA,ORFS,13)
+9 SET STAT=$PIECE(DATA,ORFS,14)
if STAT=""
QUIT
+10 ; VA Product IEN
+11 SET VAPIEN=$PIECE(DATA,ORFS,15)
+12 ; 774
SET PARK=+$PIECE(DATA,ORFS,17)
+13 if STAT=""
QUIT
+14 if 'RXSITE!('RXNUM)
QUIT
+15 ; 774 removed VAFQDN
SET @HLDAT@(DFN,RXSITE,STAT,DNAME,0)=RXNUM_U_QTY_U_REFILLS_U_DSUPP_U_EXPDT_U_ISSDATE_U_STOPDT_U_LFDT_U_STAT_U_VAPIEN_U_DNAME
+16 SET @HLDAT@(DFN,RXSITE,STAT,DNAME,"SIG")=SIG
+17 SET @HLDAT@(DFN,RXSITE,STAT,DNAME,"DETAIL")=DETAIL
+18 ; 774
SET @HLDAT@(DFN,RXSITE,STAT,DNAME,"PARK")=$SELECT($GET(PARK):1,1:0)
+19 QUIT
+20 ; build and send refill request
REFREQ ;
+1 NEW PHARM,PHONE,LOCSITE,DSUPP,MW,FILLDT,MSG,RXNUM,HLSTR,REMSITE,PHARMLN,PHARMFN,PHARMMI,TFSTRING,HLPROT,LOCDRUG,REMDRUG
+2 NEW ORFS,ORCS,ORRS,ORES,ORSS,HLQUIT,ORQUIT,RESP,RETDFN,VAPIEN,DONE,PSORRDAT,PSOHCNT,DONE,HL,CSVAL,DIR,REMSIEN,PSOHLNK,PSOLNKDN,DOMOVR,RMSDOM,PSOHLSV
+3 SET HLARR=$NAME(^TMP("HLS",$JOB))
KILL @HLARR
+4 SET HLDAT=$NAME(^XTMP("REFREQ^PSORRX1",$JOB))
KILL @HLDAT
+5 SET HLPROT="PSO REMOTE RX RDS-O13 EVENT"
+6 SET MW="W"
+7 DO FULL^VALM1
+8 SET LOCSITE=$$STA^XUAF4(DUZ(2))
+9 SET PHARM=$$GET1^DIQ(200,DUZ,.01,"E")
SET PHARMLN=$PIECE(PHARM,",")
SET PHARMFN=$PIECE($PIECE(PHARM,",",2)," ")
SET PHARMMI=$PIECE($PIECE(PHARM,",",2)," ",2)
+10 SET PHONE=$$GET1^DIQ(200,DUZ,.132,"E")
+11 SET RXNUM=$PIECE(PSOLST(ORN),U,2)
IF 'RXNUM
SET MSG(1)="Invalid Rx #. Please contact technical support."
QUIT
+12 IF SRXSTAT'="ACTIVE"
WRITE !!,"Only 'ACTIVE' remote prescriptions may be refilled at this time."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+13 ;,REMSIEN=$O(^DIC(4,"D",REMSITE,0))
SET REMSITE=$PIECE(PSOLST(ORN),U,4)
+14 SET REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
if 'REMSIEN
QUIT
+15 SET PSOREF("DFLG")=""
+16 SET REMDRUG=$PIECE(REMDATA,U,11)
SET VAPID=$PIECE(REMDATA,U,10)
+17 IF '$LENGTH(VAPID)
WRITE !!,"Missing VA Product IEN. Rx# ",RXNUM," cannot be refilled."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+18 SET LOCDRUG=$$DRUGMTCH(REMDRUG,VAPID)
+19 ; user entered no so no reason to prompt again
IF $GET(LOCDRUG)=-1
QUIT
+20 ; 774 - Remove reference to Drug Match
IF '$GET(LOCDRUG)
WRITE !,"Cannot refill Rx # ",RXNUM,"."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+21 ; PSO 740
+22 IF '$$VALDRGINT^PSORRPA1(LOCDRUG,"R",RXNUM)
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+23 ; if we got this far, fill is most likely happening and remote
+24 ; worklist needs to be rebuilt when returning, so set flag.
+25 SET PSORRBLD=1
+26 ;
+27 SET (FILLDT,PSOREF("FILL DATE"))=DT
+28 DO INIT^HLFNC2(HLPROT,.HL)
+29 DO BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
+30 SET DONE=0
+31 FOR PSOHCNT=1:1
Begin DoDot:1
+32 IF '$DATA(PSORRDAT(PSOHCNT))
SET DONE=1
QUIT
+33 SET @HLARR@(1)=$GET(@HLARR@(1))_PSORRDAT(PSOHCNT)
End DoDot:1
if DONE
QUIT
+34 ;S @HLARR@(2)="ORC^RF^"_RXNUM_"~"_REMSITE_"~"_$$GET1^DIQ(4,REMSIEN,60,"E")_"^^^^^^^"_FILLDT_U_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
+35 SET @HLARR@(2)="ORC^RF^"_RXNUM_"~"_REMSITE_"~"_$$FQDN^PSORWRAP(,REMSIEN)_"^^^^^^^"_FILLDT_U_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
+36 SET @HLARR@(3)="RXO^^^^^^^^"_MW_"~"_$$OPAI_"~~"_LOCSITE
+37 WRITE !!,"Processing refill request. Please be patient as it may take a moment"
+38 WRITE !,"for the host site to respond and generate your label data...",!
+39 SET RMSDOM=$$FQDN^PSORWRAP(,REMSIEN)
+40 SET DOMOVR=REMSITE_"~"_RMSDOM_"~DNS"
+41 SET HLP("SUBSCRIBER")="^^^^"_DOMOVR
+42 DO DIRECT^HLMA(HLPROT,"GM",1,.RESP,"",.HLP)
+43 DO READMSG^PSORRX2(.HLDAT,"RF",LOCDRUG)
+44 KILL @HLDAT,@HLARR
+45 QUIT
+46 ; build and send partial fill request
PARTIAL() ;
+1 NEW DIR,DONE,I,PRMPDAT,VAR,PRXNUM,PHARM,PHARMLN,PHARMFN,PHARMMI,PHONE,RXNUM,HLPROT,TFSTRING,HLARR,PHONE,REMSITE,HLDAT,LOCDRUG,EXIT,VAPIEN,HL,ERR
+2 NEW PSOHCNT,DONE,PSORRDAT,CSVAL,REMSIEN,PSOHLNK,PSOLNKDN,REMDRUG,Y,EXE,DOMOVR,RMSDOM,PSOHLSV,VAPID
+3 SET HLPROT="PSO REMOTE RX RDS-O13 EVENT"
+4 SET HLDAT=$NAME(^XTMP("PARTIAL^PSORRX1",$JOB))
KILL @HLDAT
+5 SET HLARR=$NAME(^TMP("HLS",$JOB))
KILL @HLARR
+6 DO FULL^VALM1
+7 IF SRXSTAT'="ACTIVE"
WRITE !!,"Only 'ACTIVE' remote prescriptions may be actioned at this time."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+8 SET LOCSITE=$$STA^XUAF4(DUZ(2))
+9 SET PHONE=$$GET1^DIQ(200,DUZ,.132,"E")
+10 SET PRXNUM=$PIECE(PSOLST(ORN),U,2)
IF 'PRXNUM
SET MSG(1)="Invalid Rx #. Please contact technical support."
QUIT
+11 SET REMSITE=$PIECE(PSOLST(ORN),U,4)
+12 SET REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
if 'REMSIEN
QUIT
+13 SET DONE=0
SET CNT=1
+14 ; prompt for fields that would normally be prompted for a local partial fill.
+15 DO FULL^VALM1
+16 SET REMDRUG=$PIECE(REMDATA,U,11)
SET VAPID=$PIECE(REMDATA,U,10)
+17 IF '$LENGTH(VAPID)
WRITE !,"Missing VA Product ID. Rx# ",PRXNUM," cannot process a partial fill."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+18 SET LOCDRUG=$$DRUGMTCH(REMDRUG,VAPID)
+19 ; user entered no so no reason to prompt again
IF $GET(LOCDRUG)=-1
QUIT
+20 ; 774 - Remove reference to Drug Match
IF '$GET(LOCDRUG)
WRITE !,"Cannot process a partial fill for Rx # ",PRXNUM,"."
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+21 ; PSO 740
+22 IF '$$VALDRGINT^PSORRPA1(LOCDRUG,"P",PRXNUM)
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+23 ; if we got this far, fill is most likely happening and remote
+24 ; worklist needs to be rebuilt when returning, so set flag.
+25 SET PSORRBLD=1
+26 SET EXIT=0
+27 SET PDATE=DT
+28 SET MW="W"
+29 FOR I=1:1
Begin DoDot:1
+30 SET PRMPDAT=$TEXT(PRMPTXT+I)
+31 SET PRMPDAT=$PIECE(PRMPDAT,";;",2)
+32 IF PRMPDAT="Q"
SET DONE=1
QUIT
+33 KILL DIR
+34 SET DIR(0)=$PIECE(PRMPDAT,"|")
SET DIR("A")=$PIECE(PRMPDAT,"|",2)
SET VAR=$PIECE(PRMPDAT,"|",4)
if $LENGTH($PIECE(PRMPDAT,"|",3))
SET DIR("B")=$PIECE(PRMPDAT,"|",3)
+35 IF $GET(DIR("B"))["~"
Begin DoDot:2
+36 SET EXE=$TRANSLATE(DIR("B"),"~","^")
XECUTE EXE
SET DIR("B")=DEF
End DoDot:2
+37 DO ^DIR
+38 IF Y="^"
SET EXIT=1
QUIT
+39 ;*499
SET @VAR=$SELECT($PIECE(DIR(0),"^")["P":$PIECE(Y,U,2),1:Y)
End DoDot:1
if DONE!(EXIT)
QUIT
+40 KILL DEF
+41 IF EXIT
WRITE !,"Cancelling partial fill request.",!
KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+42 ; if we got this far, fill attempt is happening and remote worklist
+43 ; needs to be rebuilt when returning, so set flag.
+44 SET PSORRBLD=1
+45 SET PHARMLN=$PIECE(PHARM,",")
SET PHARMFN=$PIECE($PIECE(PHARM,",",2)," ")
SET PHARMMI=$PIECE($PIECE(PHARM,",",2)," ",2)
+46 DO INIT^HLFNC2(HLPROT,.HL)
+47 DO BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
+48 SET DONE=0
+49 FOR PSOHCNT=1:1
Begin DoDot:1
+50 IF '$DATA(PSORRDAT(PSOHCNT))
SET DONE=1
QUIT
+51 SET @HLARR@(1)=$GET(@HLARR@(1))_PSORRDAT(PSOHCNT)
End DoDot:1
if DONE
QUIT
+52 SET @HLARR@(2)="ORC^PF^"_PRXNUM_"~"_REMSITE_"~"_$$FQDN^PSORWRAP(,REMSIEN)_"^^^^^^^"_PDATE_"^"_DUZ_"~"_PHARMLN_"~"_PHARMFN_"~"_PHARMMI_"^^^~~~"_LOCSITE_U_PHONE
+53 SET @HLARR@(3)="RXO^1^"_QTY_"^^^^^^"_MW_"~"_$$OPAI_"~~"_LOCSITE_"^^^"_DSUPP
+54 SET @HLARR@(4)="NTE^1^L^"_REMARKS
+55 WRITE !!,"Processing partial fill request. Please be patient as it may take a moment"
+56 WRITE !,"for the host site to respond and generate your label data...",!
+57 SET RMSDOM=$$FQDN^PSORWRAP(,REMSIEN)
+58 SET DOMOVR=REMSITE_"~"_RMSDOM_"~DNS"
+59 SET HLP("SUBSCRIBER")="^^^^"_DOMOVR
+60 DO DIRECT^HLMA(HLPROT,"GM",1,.HL,"",.HLP)
+61 IF $PIECE(HL,U,2)
Begin DoDot:1
+62 WRITE !,"An error was encountered when trying to process the results",!,"from the refill/partial fill request.",!!,$PIECE(HL,U,3)
+63 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+64 DO CL
End DoDot:1
QUIT
+65 ; clean up variables used
+66 DO READMSG^PSORRX2(.HLDAT,"PR",LOCDRUG)
CL ;
+1 KILL PDATE,QTY,DSUPP,PHARM,REMARKS,MW
+2 KILL @HLDAT,@HLARR
+3 QUIT
+4 ;
DRUGMTCH(DRGNM,VAPIN) ;p736 - VAPIEN directly passed into DRUGMTCH
+1 ; returns -1 if a match was found but user said NO
+2 ;
+3 ; p736 - ensures DRGNM is valid
IF $GET(DRGNM)']""
QUIT ""
+4 ;
+5 NEW LDIEN,MATCH,EXIT,DRL,VAGENER,FOUND,CHECK,DIC,DRGARY,LDNAME,Y,VAPSTR,MTCHSTR,DRLCNT
+6 NEW DRGNM2,MTCHSTR,DRLCNT,DRSV,CSSCH,VAPIDSTR,VAPIEN,CSPROD,VAPIENCNT,DINACT
+7 SET (CHECK,VAPSTR)=""
SET (DRLCNT,DRSV)=0
SET CSPROD=0
SET DINACT=""
+8 IF +$GET(VAPIN)
SET VAPSTR=$$GET1^DIQ(50.68,+$GET(VAPIN),2,"E")
+9 SET VAPIDSTR=$$GET1^DIQ(50.68,+$GET(VAPIN),6,"E")
+10 WRITE !!,"Remote site drug name: "_$GET(DRGNM)
+11 IF $LENGTH(VAPIDSTR)
SET VAPIEN=0
FOR
SET VAPIEN=$ORDER(^PSNDF(50.68,"C",VAPIDSTR,VAPIEN))
if 'VAPIEN
QUIT
Begin DoDot:1
+12 SET CSSCH=$$GET1^DIQ(50.68,VAPIEN,19,"I")
+13 IF '$GET(CSPROD)
IF (+CSSCH>0)
IF (+CSSCH<6)
Begin DoDot:2
+14 SET CSPROD=1
+15 WRITE !!,"VA Product ID: ",VAPIDSTR," CS FEDERAL SCHEDULE: ",+CSSCH
+16 WRITE !!,"Controlled substances are not allowed for ONEVA Pharmacy dispensing.",!
+17 DO PAUSE^VALM1
End DoDot:2
QUIT
+18 SET VAPIEN(VAPIEN)=VAPSTR
End DoDot:1
+19 ;
+20 IF CSPROD=1
QUIT 0
+21 IF '$DATA(VAPIEN(VAPIN))
WRITE !!,"Remote site VA PRODUCT IDENTIFIER: "_VAPIDSTR_" *** NOT FOUND ***",!
+22 ;
+23 ; Look for drug name
+24 IF $DATA(^PSDRUG("B",DRGNM))
Begin DoDot:1
+25 SET LDIEN=0
FOR
SET LDIEN=$ORDER(^PSDRUG("B",DRGNM,LDIEN))
if 'LDIEN
QUIT
Begin DoDot:2
+26 SET VAPIEN=""
+27 ; Filter out inactive, not on outpatient formulary, not Pharmacy orderable, not linked to VAPIDSTR, CS
+28 IF $$GET1^DIQ(50,LDIEN,63,"I")'["O"
QUIT
+29 IF $$GET1^DIQ(50,LDIEN,2.1,"I")=""
QUIT
+30 SET DINACT=$$GET1^DIQ(50,LDIEN,100,"I")
+31 IF (DINACT>0)
IF ($$DT^XLFDT>DINACT)
QUIT
+32 ; 740
SET VAPIEN=$$GET1^DIQ(50,LDIEN,22,"I")
IF VAPIEN=""
QUIT
+33 IF $$GET1^DIQ(50,LDIEN,3)
IF $$GET1^DIQ(50,LDIEN,3)>0&($$GET1^DIQ(50,LDIEN,3)<6)
QUIT
+34 IF '$DATA(DRGARY(LDIEN))
SET DRGARY(LDIEN)=""
SET DRLCNT=DRLCNT+1
End DoDot:2
End DoDot:1
+35 ;
+36 ; Quit if drug matched name and user accepted
+37 IF DRLCNT=1
Begin DoDot:1
+38 SET LDIEN=$ORDER(DRGARY(0))
+39 ;Save single match to filter from displaying from local drug
SET DRSV=LDIEN
+40 SET LDNAME=$$GET1^DIQ(50,LDIEN,.01,"E")
+41 WRITE !,"Matching Drug Found for Dispensing: "_LDNAME
+42 SET CHECK=$$DIR
End DoDot:1
IF CHECK
QUIT LDIEN
+43 ;
+44 IF DRLCNT=0
WRITE !,"No active drug name match found for "_DRGNM_"."
+45 ;
+46 SET CHECK=""
SET DRLCNT=0
KILL DRGARY
+47 SET VAPIEN=0
FOR
SET VAPIEN=$ORDER(VAPIEN(VAPIEN))
if 'VAPIEN
QUIT
Begin DoDot:1
+48 SET VAPSTR=$$GET1^DIQ(50.68,VAPIEN,2,"E")
+49 ;Loop thru the APR index in 50
+50 SET LDIEN=0
FOR
SET LDIEN=$ORDER(^PSDRUG("APR",VAPIEN,LDIEN))
if 'LDIEN
QUIT
Begin DoDot:2
+51 ;filter out inactive, drugs not on outpatient formulary, not linked to Pharmacy orderable, 'CS
+52 IF $$GET1^DIQ(50,LDIEN,100,"I")
IF (DT'<$$GET1^DIQ(50,LDIEN,100,"I"))
QUIT
+53 IF $$GET1^DIQ(50,LDIEN,63,"I")'["O"
QUIT
+54 IF $$GET1^DIQ(50,LDIEN,2.1,"I")=""
QUIT
+55 IF $$GET1^DIQ(50,LDIEN,3)
IF $$GET1^DIQ(50,LDIEN,3)>0&($$GET1^DIQ(50,LDIEN,3)<6)
+56 IF '$DATA(DRGARY(LDIEN))
SET DRGARY(LDIEN)=VAPSTR
SET DRLCNT=DRLCNT+1
End DoDot:2
End DoDot:1
+57 ;
+58 ;Filter out drug already presented
+59 IF DRSV
IF $DATA(DRGARY(DRSV))
KILL DRGARY(DRSV)
SET DRLCNT=DRLCNT-1
+60 ;
+61 IF DRLCNT
Begin DoDot:1
+62 WRITE !!,"Drugs matching the VA PRODUCT IDENTIFIER:"
+63 SET (MATCH,EXIT)=0
+64 NEW PSODRGL,PSODRGLI,PSODRGL0,PSODRGID,PSODRGC
SET DIR(0)=""
+65 FOR PSODRGLI=0:0
SET PSODRGLI=$ORDER(DRGARY(PSODRGLI))
if 'PSODRGLI
QUIT
Begin DoDot:2
+66 SET PSODRGL0=$GET(^PSDRUG(PSODRGLI,0))
SET PSODRGID=$GET(^PSDRUG(PSODRGLI,"I"))
+67 if $TRANSLATE(PSODRGL0,"^")=""
QUIT
SET PSODRGC=$GET(PSODRGC)+1
+68 SET DIR(0)=DIR(0)_$SELECT(DIR(0)]"":";",1:"")
+69 ; Increased drug name length from 30 to 40 - PSO*7*594
+70 SET DIR(0)=DIR(0)_$GET(PSODRGC)_":"_PSODRGLI_" "_$EXTRACT($PIECE(PSODRGL0,"^"),1,40)_" "_$JUSTIFY($PIECE(PSODRGL0,"^",2),7)_" "_$SELECT(PSODRGID:$EXTRACT(PSODRGID,4,5)_"-"_$EXTRACT(PSODRGID,6,7)_"-"_$EXTRACT(PSODRGID,2,3)_" ",1:"
")_...
... $PIECE(PSODRGL0,"^",10)
+71 SET DIR("L",PSODRGC)=PSODRGC_". "_PSODRGLI_" "_$EXTRACT($PIECE(PSODRGL0,"^"),1,40)_" "_$JUSTIFY($PIECE(PSODRGL0,"^",2),7)_" "_$SELECT(PSODRGID:$EXTRACT(PSODRGID,4,5)_"-"_$EXTRACT(PSODRGID,6,7)_"-"_$EXTRACT(PSODRGID,2,3)_" ",1:""
)_$PIECE(PSODRGL0,"^",10)
End DoDot:2
+72 ;1:$G(PSODRGC)"
SET DIR(0)="SO^"_DIR(0)
SET DIR("L")=""
+73 SET DIR("A")="Select Drug from list ("_1_"-"_DRLCNT_") "_"or <enter> to quit processing."
+74 DO ^DIR
KILL DIR
+75 IF +Y<1!($DATA(DUOUT))!($DATA(DTOUT))
SET Y=""
SET DRLCNT=0
+76 IF Y>0
SET LDIEN=+Y(0)
+77 IF $GET(LDIEN)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Would you like to use this drug"
DO ^DIR
+78 ;DRLCNT=0 causes Drug: to be prompted for
IF +Y<1!($DATA(DUOUT))!($DATA(DTOUT))
SET DRLCNT=0
End DoDot:1
+79 ;
+80 ;a drug was accepted
IF DRLCNT
IF $GET(Y)
QUIT LDIEN
+81 ;
+82 ;No VAPIEN, or no drug was selected or no drugs were found
+83 KILL DIR
+84 WRITE !
+85 WRITE !,"No other local match could be found for "_DRGNM_"."
+86 WRITE !,"You may need to update your Drug file to process this order"
+87 DO PAUSE^VALM1
+88 QUIT 0
+89 ;
+90 ; TEXT to build prompts
+91 ;;DIR(0)|DIR(A)|DIR(B)|VARIABLE
PRMPTXT ;
+1 ;;N^^I $D(X),X>$P(REMDATA,U,2) D EN^DDIOL("QTY CANNOT BE GREATER THAN THE ORIGINAL QTY OF "_$P(REMDATA,U,2)) K X|Enter Quantity||QTY
+2 ;;N|DAYS SUPPLY||DSUPP
+3 ;;P^200:QEAMZ|Select PHARMACIST Name|S DEF=$$GET1~DIQ(200,DUZ,.01,"E")|PHARM
+4 ;;F^0:60|REMARKS||REMARKS
+5 ;;Q
+6 QUIT
DIR() ;
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("A",1)="Would you like to use the system matched drug for this"
+4 SET DIR("A")="refill/partial fill"
+5 DO ^DIR
+6 QUIT Y
POST ; post init for PSO*7*454
+1 NEW LIEN,OPSITE,DOMAIN,VAL
+2 ; add TCP/IP address for EMI
+3 SET DOMAIN=$$FQDN^PSORWRAP(,DUZ(2))
+4 SET VAL="PSORRXSEND"
+5 SET LIEN=$$FIND1^DIC(870,,"B",.VAL)
if 'LIEN
QUIT
+6 SET FDA(870,LIEN_",",.08)=DOMAIN
+7 SET FDA(870,LIEN_",",400.01)="vaaussoalebp2.aac.domain.ext"
DO FILE^DIE(,"FDA")
KILL FDA
+8 ; turn off the OneVA Pharmacy flag for all outpatient sites.
+9 SET OPSITE=0
FOR
SET OPSITE=$ORDER(^PS(59,OPSITE))
if 'OPSITE
QUIT
Begin DoDot:1
+10 SET FDA(59,OPSITE_",",3001)=""
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
+11 QUIT
+12 ;
OPAI() ; determine if drug will go through OPAI
+1 NEW PSOOINT,PSOOMARK
+2 ;REMOVE THIS LINE ONCE YOU DETERMINE PSOSITE IS DEFINED FORM THE PROTOCOL
IF '$GET(PSOSITE)
QUIT 1
+3 SET PSOOINT=$PIECE($GET(^PS(59,PSOSITE,1)),"^",30)
SET PSOOMARK=0
+4 if +$GET(LOCDRUG)
SET PSOOMARK=+$GET(^PSDRUG(LOCDRUG,6))
+5 IF 'PSOOINT
QUIT 0
+6 IF PSOOINT=1!(PSOOINT=2)
QUIT 1
+7 IF PSOOMARK
QUIT 1
+8 QUIT 0
