APSPFUNC ;IHS/CIA/PLS - MISC FUNCTIONS ;10-May-2016 13:29;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1002,1004,1005,1006,1007,1008,1009,1010,1011,1013,1015,1017,1020,1021**;Sep 23, 2004;Build 14
;
HRC(DFN,D) ;EP; -- IHS health record number
; Input: IEN to File 200
; D - 1 for dashes (default = 0)
N HRCN
S HRCN=$P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),"^",2)
S:$G(D,0) HRCN=$$HRCD(HRCN)
Q HRCN
;
HRCD(X) ; Add dashes to given HRN value in X
S X="00000"_X,X=$E(X,$L(X)-5,$L(X))
S X=$E(X,1,2)_"-"_$E(X,3,4)_"-"_$E(X,5,6)
Q X
;
; Return most recent vital of specified type
; Return value is IEN^VALUE^DATE
VITAL(DFN,TYP) ; EP
N IDT,IEN,DAT,VIS,EIE,GOOD,RET
S GOOD=0,RET=""
S:TYP'=+TYP TYP=$O(^AUTTMSR("B",TYP,0))
Q:'TYP ""
S IDT=0
F S IDT=$O(^AUPNVMSR("AA",DFN,TYP,IDT)) Q:IDT=""!(+GOOD) D
.S IEN=$C(1)
.F S IEN=+$O(^AUPNVMSR("AA",DFN,TYP,IDT,IEN),-1) Q:'+IEN!(+GOOD) D
..S EIE=$$GET1^DIQ(9000010.01,IEN,2,"I")
..Q:EIE=1
..S X=$G(^AUPNVMSR(IEN,0)),DAT=+$G(^(12))
..S:'DAT DAT=+$G(^AUPNVSIT(+$P(X,U,3),0))
..S GOOD=1,RET=IEN_U_$P(X,U,4)_U_DAT
Q RET
; Return height in cm
VITCHT(VAL) ; EP
Q $J($G(VAL)*2.54,0,2)
; Return weight in kg
VITCWT(VAL) ; EP
Q $J($G(VAL)/2.2046226,0,2)
; Return vital date in format MM/DD/YYYY
VITDT(VAL) ; EP
Q $$FMTE^XLFDT(VAL,"5DZ0")
; Return vital information in same format at EN6^GMRVUTL
; Return format: Date^Value in Imperial Unit^Value inMetric Unit
VITALF(DFN,TYP) ; EP
N VAL,RES
S VAL=$$VITAL(DFN,TYP)
S RES=$$VITDT($P(VAL,U,3))_"^^^^^^^"_$P(VAL,U,2)_U_$$VITCWT($P(VAL,U,2))
Q RES
; Return NDC value
; Input: RX - Presciption IEN
; RF - Refill IEN
; Output: NDC value
NDCVAL(RX,RF) ; EP - Return NDC Value
; NDC value for prescription is returned if Refill IEN is not supplied
N IENS,FILE,FLD
S RF=$G(RF,0)
Q:'$G(RX) ""
S IENS=$S(RF:RF_","_RX_",",1:RX_",")
S FILE=$S(RF:52.1,1:52)
S FLD=$S(RF:11,1:27)
Q $$GET1^DIQ(FILE,IENS,FLD)
; Input: RX - Presciption IEN
; RF = Refill IEN
; NDC = NDC value to store
SETNDC(RX,RF,NDC) ; EP - Store NDC Value
N FDA,MSG
S RF=$G(RF,0)
S FL=$S(RF:52.1,1:52)
S IENS=$S(RF:RF_","_RX_",",1:RX_",")
S FLD=$S(RF:11,1:27)
S FDA(FL,IENS,FLD)=NDC
D FILE^DIE("EK","FDA","MSG")
Q $S($D(MSG):$G(MSG("DIERR",1))_" Error",1:0)
;Input: RX - Prescription IEN
; RF - Refil IEN
; OVERDUR - NCPDP 5.1 DUR segment pointer
;Output: Null if value stored; otherwise an error occurred
UPDRX(RX,RF,OVERDUR) ;PEP - Update DUR 5.1 information
N FDA,MSG
Q:'$G(RX)!'$G(OVERDUR) "-1^Required variables not present"
Q:'$D(^PSRX(RX,0)) "-2^Prescription not present"
S RF=$G(RF,0)
I RF Q:'$G(^PSRX(RX,1,RF,0)) "-3^Refill not present"
S FL=$S(RF:52.1,1:52)
S IENS=$S(RF:RF_","_RX_",",1:RX_",")
S FDA(FL,IENS,9999999.13)=OVERDUR
D FILE^DIE("EK","FDA","MSG")
Q $S($D(MSG):$G(MSG("DIERR",1))_" Error",1:0)
; Call POS Hook
CALLPOS(RIEN,RFIEN,ACT,REASON) ; EP - IHS/CIA/PLS - 03/31/04
N X,ARY
Q:'$G(RIEN)!'$L($G(ACT))
Q:$$GET1^DIQ(52,RIEN,9999999.23,"I") ;IHS/MSC/PLS - 11/02/07- Autofinished Rx
S RFIEN=$G(RFIEN)
S X=$$EN^APSQBRES(RIEN,$G(RFIEN),ACT,$G(REASON))
I $$GET^XPAR("ALL","APSP LOG ABSP MESSAGES") D
.S ARY(1)=$G(RIEN)_U_$G(RFIEN)_U_$G(ACT)_U_$G(X)_U_$G(REASON)
.D LOG^APSPPOSH(.ARY)
Q
; Display Future Fill Date Warning if needed.
FFDTWARN(FILLDT) ; EP
I $G(FILLDT)>DT D
.W !,"WARNING: The prescription has a Fill Date in the future!",!
Q
; Fire EHR Patient Context Change
SETPTCX(PSODFN) ;EP
N X
Q:$G(XQY0)="OR BCMA ORDER COM" ; IHS/MSC/PLS - 03/25/2016
S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN) Q
S X="BEHOPTCX" X ^%ZOSF("TEST") I $T D SETCTX^BEHOPTCX(+PSODFN)
Q
; Fire BOP message to ADS device
BOPSTAT ; EP
N X
S X="BOPCAP" X ^%ZOSF("TEST") I $T D STAT^BOPCAP
Q
; Return fraction value
FRACVAL(WNUM,FRAC) ; EP
N RES,OUT
S RES=""
Q:'FRAC&(WNUM>10) ""
I FRAC=".5"!(FRAC=".50") S RES="1/2"
E I FRAC=".25" S RES="1/4"
E I FRAC=".33"!(FRAC=".34") S RES="1/3"
E I FRAC=".66"!(FRAC=".67") S RES="2/3"
E I FRAC=".75" S RES="3/4"
I WNUM!RES D
.S OUT=" ("
.I WNUM S OUT=OUT_WNUM
.S OUT=OUT_$S(RES&WNUM:" AND "_RES,RES:RES,1:"")
.S:$L(OUT) OUT=OUT_")"
Q $G(OUT)
; Return fraction text
FRACTXT(FRAC) ; EP
N RES
S FRAC=$G(FRAC)
I FRAC=".5"!(FRAC=".50") S RES="ONE-HALF"
E I FRAC=".25" S RES="ONE-FOURTH"
E I FRAC=".33"!(FRAC=".34") S RES="ONE-THIRD"
E I FRAC=".66"!(FRAC=".67") S RES="TWO-THIRDS"
E I FRAC=".75" S RES="THREE-FOURTHS"
Q $G(RES)
; Return POS status
POS(RIEN) ; EP
N ANS,DIR
S ANS=""
I '$$TEST^APSQBRES("ABSPOSRX") D
.N APSQPOS,APSQPOST,APSQIT
.S APSQIT=0
.S ANS="CLAIM WAS NOT RESUBMITTED TO POS"
.S APSQPOS=$$IEN59^ABSPOSRX(RIEN,$G(RFIEN,0)) ; Get IEN in POS File
.I $G(APSQPOS) S APSQPOST=$O(^ABSPTL("B",APSQPOS,"A"),-1) ; Last entry in ^ABSPTBL global
.I $G(APSQPOST) D:+$$GET1^DIQ(9002313.57,+APSQPOST_",",.15) ; >0 indicates entry in Accounts Receivable
..S DIR("A",1)="There is an entry for this prescription in the Accounts Receivable Package"
..S DIR("A")="Do you really want to reverse this entry and resend it to the insurer and put another entry in the Accounts Receivable Package"
..S DIR("B")="YES"
..S DIR(0)="Y"
..D ^DIR
..S:Y=0 APSQIT=1
.I 'APSQIT D
..S ANS="CLAIM WAS RESUBMITTED TO POS"
..N APSQPST,RFIEN,ARY,RET
..S RFIEN=$O(^PSRX(RIEN,1,$C(1)),-1)
..D CALLPOS^APSPFUNC(RIEN,$S(RFIEN:RFIEN,1:""),"D","Reversal caused by edit.")
..S ARY("RX REF")=$S(RFIEN:RFIEN,1:0)
..S ARY("REASON")="E"
..S ARY("COM")=ANS
..D UPTLOG^APSPFNC2(.RET,RIEN,0,.ARY)
Q ANS
;
; Returns patient corresponding to 12 digit facility/hrn code
HRCNF(HRCN12) ; EP
N DFN,ASUFAC,HRN,Y
S DFN=-1
;S ASUFAC=+$E(HRCN12,1,6),HRN=+$E(HRCN12,7,12)
S ASUFAC=$E(HRCN12,1,6),HRN=+$E(HRCN12,7,12) ;P1021
Q:'ASUFAC!'HRN DFN
S ASUFAC=$$FIND1^DIC(9999999.06,,,ASUFAC,"C")
Q:'ASUFAC DFN
S Y=0 F S Y=$O(^AUPNPAT("D",HRN,Y)) Q:'Y Q:$D(^(Y,ASUFAC))
S:Y DFN=Y
Q DFN
; Return list of prescriptions on hold for patient and date range
; Input: DATA - $NA of array reference
; DFN - Patient IEN
; BDT - Beginning date - Issue Date
; EDT - End date
RXHLDLST(DATA,DFN,BDT,EDT) ;PEP -
K @DATA
Q:'$G(DFN) ; Patient must be defined
S BDT=$G(BDT,0)
S EDT=$G(EDT,DT)+.99
N HRSN,RXISD
S HRSN=0 F S HRSN=$O(^PSRX("AH",HRSN)) Q:'HRSN D
.S RX=0 F S RX=$O(^PSRX("AH",HRSN,RX)) Q:'RX D
..Q:$$GET1^DIQ(52,RX,2,"I")'=DFN
..Q:$$GET1^DIQ(52,RX,100,"I")'=3 ; Hold status
..S RXISD=$$GET1^DIQ(52,RX,1,"I") ; Get Issue Date
..Q:RXISD<BDT!(RXISD>EDT)
..S @DATA@(RX)=""
Q
; Pad string with character to specified length
PAD(S,P,L) ; EP
S $P(P,P,L)=""
Q $E(S_P,1,L)
;
; Return formatted phone number
FMTPHN(X) ;EP
N RES
I $E(X,1,10)?10N Q "("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_$S($L($E(X,11,20)):" "_$E(X,11,20),1:"")
I $E(X,1,7)?7N Q $E(X,1,3)_"-"_$E(X,4,7)_" "_$E(8,20)
I X?10N1" ".6UN Q "("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_$S($L($E(X,11,20)):" "_$E(X,11,20),1:"")
I X?3N1"-"3N1"-"4N.1" ".A Q "("_$E(X,1,3)_")"_$E(X,5,12)_" "_$E(X,13,20)
I X?3N1"-"4N Q X
I X?3N1"-"4N.1" ".6UN Q X
Q X
; Returns value of POE field for given prescription with DEA Class rules applied
ISPOE(RX) ;PEP -
N POE,DRG
S POE=+$P($G(^PSRX(RX,"POE")),U)
Q:'POE 0
S DRG=+$P($G(^PSRX(RX,0)),U,6)
Q:'DRG 0
Q '$$ISSCH^APSPFNC2(DRG,"2345")
; Removes RXs with future fill date from PPL string
; Input: PPL - List of comma delimited RXs
; SFLG - Passing 1 will remove the future RXs from PPL
CHKFDT(PPL,SFLG) ; EP
N LP,RX,PPLARY,FFLG
Q:'$G(PPL)
S SFLG=$G(SFLG,0)
D BPPLARY(PPL)
S RX=0 F S RX=$O(PPLARY(RX)) Q:'RX D
.S PPLARY(RX)=$$FILLDT(RX)>$$DT^XLFDT()
.S:PPLARY(RX) FFLG=1
D:$G(FFLG) FDTWARN(.PPLARY)
D:SFLG BPPLSTR(.PPLARY)
Q
; Extracts PPL string into an array
BPPLARY(PPL) ;EP
N LP,RX
F LP=1:1 Q:$P(PPL,",",LP)="" D
.S RX=$P(PPL,",",LP)
.S PPLARY(RX)=""
Q
; Builds PPL string from array excluding flagged items
BPPLSTR(PPLARY) ;EP
N RX
S PPL=""
S RX=0 F S RX=$O(PPLARY(RX)) Q:'RX D
.S:'PPLARY(RX) PPL=PPL_RX_","
Q
; Returns Fill Date of Prescription
FILLDT(RX) ;EP
N LFN,REF,RF0,FDAT
S LFN=+$O(^PSRX(RX,1,$C(1)),-1)
S FDAT=$S(LFN:+$P($G(^PSRX(RX,1,LFN,0)),U),1:+$P($G(^PSRX(RX,2)),U,2))
Q FDAT
; Displays warning that labels will not be printed for RXs with future fill dates
FDTWARN(PPLARY) ;EP
N RX
W !,"The following prescription labels will not be generated because"
W !,"of a Future Fill date:"
S RX=0 F S RX=$O(PPLARY(RX)) Q:'RX D
.I PPLARY(RX) D
..W !,"RX: "_$P($G(^PSRX(RX,0)),U)," Fill Date: "_$$FMTE^XLFDT($$FILLDT(RX),"5Z")
W !,"Please edit the fill date(s) or place the prescription(s) on suspense."
Q
; Return status of prescription
RXSTAT(RX) ;EP
Q $G(^PSRX(RX,"STA"))
; Return user's DEA, or Facility DEA-VA-USPHS or null
DEAVAUS(PRV) ;EP -
; 1. If provider DEA# exists in File 200 use that.
; 2. If no provider DEA# exists but has VA#
; then return Facility DEA-VA-USPHS
; else return null
; Facility DEA#-VA#-USPHS (ie AU1234567-BB1234-USPHS)
Q:$G(PRV)="" ""
N DEAID,VAID,RET,FACID
S RET=""
S DEAID=$$GET1^DIQ(200,PRV,53.2) ;Provider DEA#
S VAID=$$GET1^DIQ(200,PRV,53.3) ;Provider VA#
S FACID=$$GET1^DIQ(4,DUZ(2),52) ;Facility DEA#
I $L(DEAID) D
.S RET=DEAID
E I $L(VAID) D
.S RET=FACID_"-"_VAID_"-"_"USPHS"
Q RET
; Returns remaining refill count
; Input: RX : Prescription IEN - Required
; FDT: Fill date - optional - If passed will restrict count to
; refill count to exclude refills past the value in FDT.
RMNRFL(RX,FDT) ;EP-
N RFS,IEN
S RX=$G(RX,0)
Q:'$D(^PSRX(RX,0)) 0
S RFS=$P(^PSRX(RX,0),U,9),IEN=0 F S IEN=$O(^PSRX(RX,1,IEN)) Q:'IEN D
.I $G(FDT) Q:$P(^PSRX(RX,1,IEN,0),U)>FDT
.S RFS=RFS-1
Q RFS
; Prompt for electronic signature
ESIG() ;EP-
N X,X1
D SIG^XUSESIG
Q X1'=""
; Return Masked SSN
FMTSSN(SSN) ;EP-
N X
S SSN=$TR(SSN,"-","")
S X=$E(SSN,6,$L(SSN))
Q "XXX-XX-"_$S($L(X):X,1:"XXXX")
; Prompt user for processing on pending flagged order
PMTFORD(POIEN) ;EP-
N DRG,ORDITM,P0,FLG,ISSDT,PRV,HLP
S P0=$G(^PS(52.41,POIEN,0))
S FLG=$$ISORDFLG(+P0)
Q:'FLG 1
S DRG=$$GET1^DIQ(52.41,POIEN,11)
S ORDITM=$$GET1^DIQ(52.41,POIEN,8)
S ISSDT=$$FMTE^XLFDT($P($P(P0,U,6),"."),"5Z")
S PRV=$$GET1^DIQ(52.41,POIEN,5)
W !!,"Dispense or Orderable Item: "_$S($L(DRG):DRG,1:ORDITM)
W !,"Issue Date: "_ISSDT
W !,"Ordering Provider: "_PRV
W !!,"This order has been flagged!",!
W !,"Date/Time flagged: "_$$FMTE^XLFDT($P(FLG,U,3),"5Z")_" Flagged by: "_$$GET1^DIQ(200,$P(FLG,U,4),.01)
W !,"Reason for flag: "_$P(FLG,U,5)
W !!
Q ''$$DIR^APSPUTIL("Y","Continue Processing",,.HLP)
; Return flagged status of order
ISORDFLG(ORDID) ;EP-
N RES,LP,ACT0
S RES=0
S LP=0 F S LP=$O(^OR(100,+ORDID,8,LP)) Q:'LP D
.S ACT0=$G(^OR(100,+ORDID,8,LP,3))
.I ACT0 D
..S RES=ACT0
Q RES
; Return order check of type ALLERGY-DRUG INTERACTION
ISADCHK(ORDID,CHKIEN) ;EP-
Q:'$G(CHKIEN) 0
Q $$GET1^DIQ(100.8,$P($G(^OR(100,+ORDID,9,CHKIEN,0)),U),.01)="ALLERGY-DRUG INTERACTION"
; Check array for existing string
SRCHARY(ARY,STR) ;EP-
N LINE,FLAG,STRX S LINE=0,FLAG=0,OUT=0
S STRX=""
Q:'$L($G(STR)) OUT
I $D(STR)>1 D
.F S LINE=$O(STR(LINE)) Q:'LINE D
..S STRX=STRX_STR(LINE)
E S STRX=STR
S LINE=0
S STRX=$$UP^XLFSTR(STRX)
S STRX=$TR(STRX," ","")
Q:'$L(STRX) 0
F S LINE=+$O(ARY(LINE)) Q:'LINE D Q:'FLAG Q:OUT
. N X1
. S X1=$$UP^XLFSTR(ARY(LINE)),X1=$TR(X1," ","")
. S FLAG=+$O(ARY(LINE))
. I 'FLAG S:X1[STRX OUT=1 Q
. S X1=X1_$$UP^XLFSTR(ARY(FLAG)),X1=$TR(X1," ","")
. I X1[STRX S OUT=1 Q
Q OUT
; Display REM message to user
REMMSG(DRG) ;EP-
N VAIEN,DNAME
S DNAME=$$GET1^DIQ(50,DRG,.01)
S VAIEN=$$GET1^DIQ(50,DRG,22,"I")
I $L($$GET1^DIQ(50.68,VAIEN,100)) D
.W !,DNAME_" requires an FDA medication guide."
.W !,"Please take appropriate action and print a patient medication guide if necessary."
.;Q:''$$DIR^APSPUTIL("Y","Continue Processing",,.HLP)
.D DIRZ^APSPUTIL()
Q
; Prompt for comment on Inpatient orders.
INPTCOM(COM) ;EP-
W !
N DIR,DTOUT,DUOUT,DIRUT,COM,Y
S RES=""
S DIR("A")="Comments"_$S($D(PKIR):"/Reason for DCing",1:""),DIR(0)="F^5:75"
S DIR("?")="Comments must be entered. Comments must be 5 to 75 characters and must not contain embedded uparrow"
S:$D(COM) DIR("B")=$G(COM)
D ^DIR
S COM=$S('$D(DIRUT):Y,1:"")
Q COM
; Ask for Fill Priority
APRTY ;EP-
N DA,DIR
S DIR("A")="Fill Priority"
S DIR("B")=$$GET1^DIQ(9009033,PSOSITE,406)
S DIR(0)="52,9999999.38" D ^DIR
S APSPPRIO=$S($L($G(Y(0))):Y,1:"")
Q
; Return status of Beyond Use field in 59.5
BYU(SITE) ;EP-
Q +$S('$G(SITE):0,1:$G(^PS(59.5,SITE,9999999)))
APSPFUNC ;IHS/CIA/PLS - MISC FUNCTIONS ;10-May-2016 13:29;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1002,1004,1005,1006,1007,1008,1009,1010,1011,1013,1015,1017,1020,1021**;Sep 23, 2004;Build 14
+2 ;
HRC(DFN,D) ;EP; -- IHS health record number
+1 ; Input: IEN to File 200
+2 ; D - 1 for dashes (default = 0)
+3 NEW HRCN
+4 SET HRCN=$PIECE($GET(^AUPNPAT(+$GET(DFN),41,+$GET(DUZ(2)),0)),"^",2)
+5 IF $GET(D,0)
SET HRCN=$$HRCD(HRCN)
+6 QUIT HRCN
+7 ;
HRCD(X) ; Add dashes to given HRN value in X
+1 SET X="00000"_X
SET X=$EXTRACT(X,$LENGTH(X)-5,$LENGTH(X))
+2 SET X=$EXTRACT(X,1,2)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,5,6)
+3 QUIT X
+4 ;
+5 ; Return most recent vital of specified type
+6 ; Return value is IEN^VALUE^DATE
VITAL(DFN,TYP) ; EP
+1 NEW IDT,IEN,DAT,VIS,EIE,GOOD,RET
+2 SET GOOD=0
SET RET=""
+3 IF TYP'=+TYP
SET TYP=$ORDER(^AUTTMSR("B",TYP,0))
+4 IF 'TYP
QUIT ""
+5 SET IDT=0
+6 FOR
SET IDT=$ORDER(^AUPNVMSR("AA",DFN,TYP,IDT))
IF IDT=""!(+GOOD)
QUIT
Begin DoDot:1
+7 SET IEN=$CHAR(1)
+8 FOR
SET IEN=+$ORDER(^AUPNVMSR("AA",DFN,TYP,IDT,IEN),-1)
IF '+IEN!(+GOOD)
QUIT
Begin DoDot:2
+9 SET EIE=$$GET1^DIQ(9000010.01,IEN,2,"I")
+10 IF EIE=1
QUIT
+11 SET X=$GET(^AUPNVMSR(IEN,0))
SET DAT=+$GET(^(12))
+12 IF 'DAT
SET DAT=+$GET(^AUPNVSIT(+$PIECE(X,U,3),0))
+13 SET GOOD=1
SET RET=IEN_U_$PIECE(X,U,4)_U_DAT
End DoDot:2
End DoDot:1
+14 QUIT RET
+15 ; Return height in cm
VITCHT(VAL) ; EP
+1 QUIT $JUSTIFY($GET(VAL)*2.54,0,2)
+2 ; Return weight in kg
VITCWT(VAL) ; EP
+1 QUIT $JUSTIFY($GET(VAL)/2.2046226,0,2)
+2 ; Return vital date in format MM/DD/YYYY
VITDT(VAL) ; EP
+1 QUIT $$FMTE^XLFDT(VAL,"5DZ0")
+2 ; Return vital information in same format at EN6^GMRVUTL
+3 ; Return format: Date^Value in Imperial Unit^Value inMetric Unit
VITALF(DFN,TYP) ; EP
+1 NEW VAL,RES
+2 SET VAL=$$VITAL(DFN,TYP)
+3 SET RES=$$VITDT($PIECE(VAL,U,3))_"^^^^^^^"_$PIECE(VAL,U,2)_U_$$VITCWT($PIECE(VAL,U,2))
+4 QUIT RES
+5 ; Return NDC value
+6 ; Input: RX - Presciption IEN
+7 ; RF - Refill IEN
+8 ; Output: NDC value
NDCVAL(RX,RF) ; EP - Return NDC Value
+1 ; NDC value for prescription is returned if Refill IEN is not supplied
+2 NEW IENS,FILE,FLD
+3 SET RF=$GET(RF,0)
+4 IF '$GET(RX)
QUIT ""
+5 SET IENS=$SELECT(RF:RF_","_RX_",",1:RX_",")
+6 SET FILE=$SELECT(RF:52.1,1:52)
+7 SET FLD=$SELECT(RF:11,1:27)
+8 QUIT $$GET1^DIQ(FILE,IENS,FLD)
+9 ; Input: RX - Presciption IEN
+10 ; RF = Refill IEN
+11 ; NDC = NDC value to store
SETNDC(RX,RF,NDC) ; EP - Store NDC Value
+1 NEW FDA,MSG
+2 SET RF=$GET(RF,0)
+3 SET FL=$SELECT(RF:52.1,1:52)
+4 SET IENS=$SELECT(RF:RF_","_RX_",",1:RX_",")
+5 SET FLD=$SELECT(RF:11,1:27)
+6 SET FDA(FL,IENS,FLD)=NDC
+7 DO FILE^DIE("EK","FDA","MSG")
+8 QUIT $SELECT($DATA(MSG):$GET(MSG("DIERR",1))_" Error",1:0)
+9 ;Input: RX - Prescription IEN
+10 ; RF - Refil IEN
+11 ; OVERDUR - NCPDP 5.1 DUR segment pointer
+12 ;Output: Null if value stored; otherwise an error occurred
UPDRX(RX,RF,OVERDUR) ;PEP - Update DUR 5.1 information
+1 NEW FDA,MSG
+2 IF '$GET(RX)!'$GET(OVERDUR)
QUIT "-1^Required variables not present"
+3 IF '$DATA(^PSRX(RX,0))
QUIT "-2^Prescription not present"
+4 SET RF=$GET(RF,0)
+5 IF RF
IF '$GET(^PSRX(RX,1,RF,0))
QUIT "-3^Refill not present"
+6 SET FL=$SELECT(RF:52.1,1:52)
+7 SET IENS=$SELECT(RF:RF_","_RX_",",1:RX_",")
+8 SET FDA(FL,IENS,9999999.13)=OVERDUR
+9 DO FILE^DIE("EK","FDA","MSG")
+10 QUIT $SELECT($DATA(MSG):$GET(MSG("DIERR",1))_" Error",1:0)
+11 ; Call POS Hook
CALLPOS(RIEN,RFIEN,ACT,REASON) ; EP - IHS/CIA/PLS - 03/31/04
+1 NEW X,ARY
+2 IF '$GET(RIEN)!'$LENGTH($GET(ACT))
QUIT
+3 ;IHS/MSC/PLS - 11/02/07- Autofinished Rx
IF $$GET1^DIQ(52,RIEN,9999999.23,"I")
QUIT
+4 SET RFIEN=$GET(RFIEN)
+5 SET X=$$EN^APSQBRES(RIEN,$GET(RFIEN),ACT,$GET(REASON))
+6 IF $$GET^XPAR("ALL","APSP LOG ABSP MESSAGES")
Begin DoDot:1
+7 SET ARY(1)=$GET(RIEN)_U_$GET(RFIEN)_U_$GET(ACT)_U_$GET(X)_U_$GET(REASON)
+8 DO LOG^APSPPOSH(.ARY)
End DoDot:1
+9 QUIT
+10 ; Display Future Fill Date Warning if needed.
FFDTWARN(FILLDT) ; EP
+1 IF $GET(FILLDT)>DT
Begin DoDot:1
+2 WRITE !,"WARNING: The prescription has a Fill Date in the future!",!
End DoDot:1
+3 QUIT
+4 ; Fire EHR Patient Context Change
SETPTCX(PSODFN) ;EP
+1 NEW X
+2 ; IHS/MSC/PLS - 03/25/2016
IF $GET(XQY0)="OR BCMA ORDER COM"
QUIT
+3 SET X="CIAVCXPT"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO SETCTX^CIAVCXPT(+PSODFN)
QUIT
+4 SET X="BEHOPTCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO SETCTX^BEHOPTCX(+PSODFN)
+5 QUIT
+6 ; Fire BOP message to ADS device
BOPSTAT ; EP
+1 NEW X
+2 SET X="BOPCAP"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO STAT^BOPCAP
+3 QUIT
+4 ; Return fraction value
FRACVAL(WNUM,FRAC) ; EP
+1 NEW RES,OUT
+2 SET RES=""
+3 IF 'FRAC&(WNUM>10)
QUIT ""
+4 IF FRAC=".5"!(FRAC=".50")
SET RES="1/2"
+5 IF '$TEST
IF FRAC=".25"
SET RES="1/4"
+6 IF '$TEST
IF FRAC=".33"!(FRAC=".34")
SET RES="1/3"
+7 IF '$TEST
IF FRAC=".66"!(FRAC=".67")
SET RES="2/3"
+8 IF '$TEST
IF FRAC=".75"
SET RES="3/4"
+9 IF WNUM!RES
Begin DoDot:1
+10 SET OUT=" ("
+11 IF WNUM
SET OUT=OUT_WNUM
+12 SET OUT=OUT_$SELECT(RES&WNUM:" AND "_RES,RES:RES,1:"")
+13 IF $LENGTH(OUT)
SET OUT=OUT_")"
End DoDot:1
+14 QUIT $GET(OUT)
+15 ; Return fraction text
FRACTXT(FRAC) ; EP
+1 NEW RES
+2 SET FRAC=$GET(FRAC)
+3 IF FRAC=".5"!(FRAC=".50")
SET RES="ONE-HALF"
+4 IF '$TEST
IF FRAC=".25"
SET RES="ONE-FOURTH"
+5 IF '$TEST
IF FRAC=".33"!(FRAC=".34")
SET RES="ONE-THIRD"
+6 IF '$TEST
IF FRAC=".66"!(FRAC=".67")
SET RES="TWO-THIRDS"
+7 IF '$TEST
IF FRAC=".75"
SET RES="THREE-FOURTHS"
+8 QUIT $GET(RES)
+9 ; Return POS status
POS(RIEN) ; EP
+1 NEW ANS,DIR
+2 SET ANS=""
+3 IF '$$TEST^APSQBRES("ABSPOSRX")
Begin DoDot:1
+4 NEW APSQPOS,APSQPOST,APSQIT
+5 SET APSQIT=0
+6 SET ANS="CLAIM WAS NOT RESUBMITTED TO POS"
+7 ; Get IEN in POS File
SET APSQPOS=$$IEN59^ABSPOSRX(RIEN,$GET(RFIEN,0))
+8 ; Last entry in ^ABSPTBL global
IF $GET(APSQPOS)
SET APSQPOST=$ORDER(^ABSPTL("B",APSQPOS,"A"),-1)
+9 ; >0 indicates entry in Accounts Receivable
IF $GET(APSQPOST)
IF +$$GET1^DIQ(9002313.57,+APSQPOST_",",.15)
Begin DoDot:2
+10 SET DIR("A",1)="There is an entry for this prescription in the Accounts Receivable Package"
+11 SET DIR("A")="Do you really want to reverse this entry and resend it to the insurer and put another entry in the Accounts Receivable Package"
+12 SET DIR("B")="YES"
+13 SET DIR(0)="Y"
+14 DO ^DIR
+15 IF Y=0
SET APSQIT=1
End DoDot:2
+16 IF 'APSQIT
Begin DoDot:2
+17 SET ANS="CLAIM WAS RESUBMITTED TO POS"
+18 NEW APSQPST,RFIEN,ARY,RET
+19 SET RFIEN=$ORDER(^PSRX(RIEN,1,$CHAR(1)),-1)
+20 DO CALLPOS^APSPFUNC(RIEN,$SELECT(RFIEN:RFIEN,1:""),"D","Reversal caused by edit.")
+21 SET ARY("RX REF")=$SELECT(RFIEN:RFIEN,1:0)
+22 SET ARY("REASON")="E"
+23 SET ARY("COM")=ANS
+24 DO UPTLOG^APSPFNC2(.RET,RIEN,0,.ARY)
End DoDot:2
End DoDot:1
+25 QUIT ANS
+26 ;
+27 ; Returns patient corresponding to 12 digit facility/hrn code
HRCNF(HRCN12) ; EP
+1 NEW DFN,ASUFAC,HRN,Y
+2 SET DFN=-1
+3 ;S ASUFAC=+$E(HRCN12,1,6),HRN=+$E(HRCN12,7,12)
+4 ;P1021
SET ASUFAC=$EXTRACT(HRCN12,1,6)
SET HRN=+$EXTRACT(HRCN12,7,12)
+5 IF 'ASUFAC!'HRN
QUIT DFN
+6 SET ASUFAC=$$FIND1^DIC(9999999.06,,,ASUFAC,"C")
+7 IF 'ASUFAC
QUIT DFN
+8 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT("D",HRN,Y))
IF 'Y
QUIT
IF $DATA(^(Y,ASUFAC))
QUIT
+9 IF Y
SET DFN=Y
+10 QUIT DFN
+11 ; Return list of prescriptions on hold for patient and date range
+12 ; Input: DATA - $NA of array reference
+13 ; DFN - Patient IEN
+14 ; BDT - Beginning date - Issue Date
+15 ; EDT - End date
RXHLDLST(DATA,DFN,BDT,EDT) ;PEP -
+1 KILL @DATA
+2 ; Patient must be defined
IF '$GET(DFN)
QUIT
+3 SET BDT=$GET(BDT,0)
+4 SET EDT=$GET(EDT,DT)+.99
+5 NEW HRSN,RXISD
+6 SET HRSN=0
FOR
SET HRSN=$ORDER(^PSRX("AH",HRSN))
IF 'HRSN
QUIT
Begin DoDot:1
+7 SET RX=0
FOR
SET RX=$ORDER(^PSRX("AH",HRSN,RX))
IF 'RX
QUIT
Begin DoDot:2
+8 IF $$GET1^DIQ(52,RX,2,"I")'=DFN
QUIT
+9 ; Hold status
IF $$GET1^DIQ(52,RX,100,"I")'=3
QUIT
+10 ; Get Issue Date
SET RXISD=$$GET1^DIQ(52,RX,1,"I")
+11 IF RXISD<BDT!(RXISD>EDT)
QUIT
+12 SET @DATA@(RX)=""
End DoDot:2
End DoDot:1
+13 QUIT
+14 ; Pad string with character to specified length
PAD(S,P,L) ; EP
+1 SET $PIECE(P,P,L)=""
+2 QUIT $EXTRACT(S_P,1,L)
+3 ;
+4 ; Return formatted phone number
FMTPHN(X) ;EP
+1 NEW RES
+2 IF $EXTRACT(X,1,10)?10N
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_$SELECT($LENGTH($EXTRACT(X,11,20)):" "_$EXTRACT(X,11,20),1:"")
+3 IF $EXTRACT(X,1,7)?7N
QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,7)_" "_$EXTRACT(8,20)
+4 IF X?10N1" ".6UN
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_$SELECT($LENGTH($EXTRACT(X,11,20)):" "_$EXTRACT(X,11,20),1:"")
+5 IF X?3N1"-"3N1"-"4N.1" ".A
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,5,12)_" "_$EXTRACT(X,13,20)
+6 IF X?3N1"-"4N
QUIT X
+7 IF X?3N1"-"4N.1" ".6UN
QUIT X
+8 QUIT X
+9 ; Returns value of POE field for given prescription with DEA Class rules applied
ISPOE(RX) ;PEP -
+1 NEW POE,DRG
+2 SET POE=+$PIECE($GET(^PSRX(RX,"POE")),U)
+3 IF 'POE
QUIT 0
+4 SET DRG=+$PIECE($GET(^PSRX(RX,0)),U,6)
+5 IF 'DRG
QUIT 0
+6 QUIT '$$ISSCH^APSPFNC2(DRG,"2345")
+7 ; Removes RXs with future fill date from PPL string
+8 ; Input: PPL - List of comma delimited RXs
+9 ; SFLG - Passing 1 will remove the future RXs from PPL
CHKFDT(PPL,SFLG) ; EP
+1 NEW LP,RX,PPLARY,FFLG
+2 IF '$GET(PPL)
QUIT
+3 SET SFLG=$GET(SFLG,0)
+4 DO BPPLARY(PPL)
+5 SET RX=0
FOR
SET RX=$ORDER(PPLARY(RX))
IF 'RX
QUIT
Begin DoDot:1
+6 SET PPLARY(RX)=$$FILLDT(RX)>$$DT^XLFDT()
+7 IF PPLARY(RX)
SET FFLG=1
End DoDot:1
+8 IF $GET(FFLG)
DO FDTWARN(.PPLARY)
+9 IF SFLG
DO BPPLSTR(.PPLARY)
+10 QUIT
+11 ; Extracts PPL string into an array
BPPLARY(PPL) ;EP
+1 NEW LP,RX
+2 FOR LP=1:1
IF $PIECE(PPL,",",LP)=""
QUIT
Begin DoDot:1
+3 SET RX=$PIECE(PPL,",",LP)
+4 SET PPLARY(RX)=""
End DoDot:1
+5 QUIT
+6 ; Builds PPL string from array excluding flagged items
BPPLSTR(PPLARY) ;EP
+1 NEW RX
+2 SET PPL=""
+3 SET RX=0
FOR
SET RX=$ORDER(PPLARY(RX))
IF 'RX
QUIT
Begin DoDot:1
+4 IF 'PPLARY(RX)
SET PPL=PPL_RX_","
End DoDot:1
+5 QUIT
+6 ; Returns Fill Date of Prescription
FILLDT(RX) ;EP
+1 NEW LFN,REF,RF0,FDAT
+2 SET LFN=+$ORDER(^PSRX(RX,1,$CHAR(1)),-1)
+3 SET FDAT=$SELECT(LFN:+$PIECE($GET(^PSRX(RX,1,LFN,0)),U),1:+$PIECE($GET(^PSRX(RX,2)),U,2))
+4 QUIT FDAT
+5 ; Displays warning that labels will not be printed for RXs with future fill dates
FDTWARN(PPLARY) ;EP
+1 NEW RX
+2 WRITE !,"The following prescription labels will not be generated because"
+3 WRITE !,"of a Future Fill date:"
+4 SET RX=0
FOR
SET RX=$ORDER(PPLARY(RX))
IF 'RX
QUIT
Begin DoDot:1
+5 IF PPLARY(RX)
Begin DoDot:2
+6 WRITE !,"RX: "_$PIECE($GET(^PSRX(RX,0)),U)," Fill Date: "_$$FMTE^XLFDT($$FILLDT(RX),"5Z")
End DoDot:2
End DoDot:1
+7 WRITE !,"Please edit the fill date(s) or place the prescription(s) on suspense."
+8 QUIT
+9 ; Return status of prescription
RXSTAT(RX) ;EP
+1 QUIT $GET(^PSRX(RX,"STA"))
+2 ; Return user's DEA, or Facility DEA-VA-USPHS or null
DEAVAUS(PRV) ;EP -
+1 ; 1. If provider DEA# exists in File 200 use that.
+2 ; 2. If no provider DEA# exists but has VA#
+3 ; then return Facility DEA-VA-USPHS
+4 ; else return null
+5 ; Facility DEA#-VA#-USPHS (ie AU1234567-BB1234-USPHS)
+6 IF $GET(PRV)=""
QUIT ""
+7 NEW DEAID,VAID,RET,FACID
+8 SET RET=""
+9 ;Provider DEA#
SET DEAID=$$GET1^DIQ(200,PRV,53.2)
+10 ;Provider VA#
SET VAID=$$GET1^DIQ(200,PRV,53.3)
+11 ;Facility DEA#
SET FACID=$$GET1^DIQ(4,DUZ(2),52)
+12 IF $LENGTH(DEAID)
Begin DoDot:1
+13 SET RET=DEAID
End DoDot:1
+14 IF '$TEST
IF $LENGTH(VAID)
Begin DoDot:1
+15 SET RET=FACID_"-"_VAID_"-"_"USPHS"
End DoDot:1
+16 QUIT RET
+17 ; Returns remaining refill count
+18 ; Input: RX : Prescription IEN - Required
+19 ; FDT: Fill date - optional - If passed will restrict count to
+20 ; refill count to exclude refills past the value in FDT.
RMNRFL(RX,FDT) ;EP-
+1 NEW RFS,IEN
+2 SET RX=$GET(RX,0)
+3 IF '$DATA(^PSRX(RX,0))
QUIT 0
+4 SET RFS=$PIECE(^PSRX(RX,0),U,9)
SET IEN=0
FOR
SET IEN=$ORDER(^PSRX(RX,1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $GET(FDT)
IF $PIECE(^PSRX(RX,1,IEN,0),U)>FDT
QUIT
+6 SET RFS=RFS-1
End DoDot:1
+7 QUIT RFS
+8 ; Prompt for electronic signature
ESIG() ;EP-
+1 NEW X,X1
+2 DO SIG^XUSESIG
+3 QUIT X1'=""
+4 ; Return Masked SSN
FMTSSN(SSN) ;EP-
+1 NEW X
+2 SET SSN=$TRANSLATE(SSN,"-","")
+3 SET X=$EXTRACT(SSN,6,$LENGTH(SSN))
+4 QUIT "XXX-XX-"_$SELECT($LENGTH(X):X,1:"XXXX")
+5 ; Prompt user for processing on pending flagged order
PMTFORD(POIEN) ;EP-
+1 NEW DRG,ORDITM,P0,FLG,ISSDT,PRV,HLP
+2 SET P0=$GET(^PS(52.41,POIEN,0))
+3 SET FLG=$$ISORDFLG(+P0)
+4 IF 'FLG
QUIT 1
+5 SET DRG=$$GET1^DIQ(52.41,POIEN,11)
+6 SET ORDITM=$$GET1^DIQ(52.41,POIEN,8)
+7 SET ISSDT=$$FMTE^XLFDT($PIECE($PIECE(P0,U,6),"."),"5Z")
+8 SET PRV=$$GET1^DIQ(52.41,POIEN,5)
+9 WRITE !!,"Dispense or Orderable Item: "_$SELECT($LENGTH(DRG):DRG,1:ORDITM)
+10 WRITE !,"Issue Date: "_ISSDT
+11 WRITE !,"Ordering Provider: "_PRV
+12 WRITE !!,"This order has been flagged!",!
+13 WRITE !,"Date/Time flagged: "_$$FMTE^XLFDT($PIECE(FLG,U,3),"5Z")_" Flagged by: "_$$GET1^DIQ(200,$PIECE(FLG,U,4),.01)
+14 WRITE !,"Reason for flag: "_$PIECE(FLG,U,5)
+15 WRITE !!
+16 QUIT ''$$DIR^APSPUTIL("Y","Continue Processing",,.HLP)
+17 ; Return flagged status of order
ISORDFLG(ORDID) ;EP-
+1 NEW RES,LP,ACT0
+2 SET RES=0
+3 SET LP=0
FOR
SET LP=$ORDER(^OR(100,+ORDID,8,LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET ACT0=$GET(^OR(100,+ORDID,8,LP,3))
+5 IF ACT0
Begin DoDot:2
+6 SET RES=ACT0
End DoDot:2
End DoDot:1
+7 QUIT RES
+8 ; Return order check of type ALLERGY-DRUG INTERACTION
ISADCHK(ORDID,CHKIEN) ;EP-
+1 IF '$GET(CHKIEN)
QUIT 0
+2 QUIT $$GET1^DIQ(100.8,$PIECE($GET(^OR(100,+ORDID,9,CHKIEN,0)),U),.01)="ALLERGY-DRUG INTERACTION"
+3 ; Check array for existing string
SRCHARY(ARY,STR) ;EP-
+1 NEW LINE,FLAG,STRX
SET LINE=0
SET FLAG=0
SET OUT=0
+2 SET STRX=""
+3 IF '$LENGTH($GET(STR))
QUIT OUT
+4 IF $DATA(STR)>1
Begin DoDot:1
+5 FOR
SET LINE=$ORDER(STR(LINE))
IF 'LINE
QUIT
Begin DoDot:2
+6 SET STRX=STRX_STR(LINE)
End DoDot:2
End DoDot:1
+7 IF '$TEST
SET STRX=STR
+8 SET LINE=0
+9 SET STRX=$$UP^XLFSTR(STRX)
+10 SET STRX=$TRANSLATE(STRX," ","")
+11 IF '$LENGTH(STRX)
QUIT 0
+12 FOR
SET LINE=+$ORDER(ARY(LINE))
IF 'LINE
QUIT
Begin DoDot:1
+13 NEW X1
+14 SET X1=$$UP^XLFSTR(ARY(LINE))
SET X1=$TRANSLATE(X1," ","")
+15 SET FLAG=+$ORDER(ARY(LINE))
+16 IF 'FLAG
IF X1[STRX
SET OUT=1
QUIT
+17 SET X1=X1_$$UP^XLFSTR(ARY(FLAG))
SET X1=$TRANSLATE(X1," ","")
+18 IF X1[STRX
SET OUT=1
QUIT
End DoDot:1
IF 'FLAG
QUIT
IF OUT
QUIT
+19 QUIT OUT
+20 ; Display REM message to user
REMMSG(DRG) ;EP-
+1 NEW VAIEN,DNAME
+2 SET DNAME=$$GET1^DIQ(50,DRG,.01)
+3 SET VAIEN=$$GET1^DIQ(50,DRG,22,"I")
+4 IF $LENGTH($$GET1^DIQ(50.68,VAIEN,100))
Begin DoDot:1
+5 WRITE !,DNAME_" requires an FDA medication guide."
+6 WRITE !,"Please take appropriate action and print a patient medication guide if necessary."
+7 ;Q:''$$DIR^APSPUTIL("Y","Continue Processing",,.HLP)
+8 DO DIRZ^APSPUTIL()
End DoDot:1
+9 QUIT
+10 ; Prompt for comment on Inpatient orders.
INPTCOM(COM) ;EP-
+1 WRITE !
+2 NEW DIR,DTOUT,DUOUT,DIRUT,COM,Y
+3 SET RES=""
+4 SET DIR("A")="Comments"_$SELECT($DATA(PKIR):"/Reason for DCing",1:"")
SET DIR(0)="F^5:75"
+5 SET DIR("?")="Comments must be entered. Comments must be 5 to 75 characters and must not contain embedded uparrow"
+6 IF $DATA(COM)
SET DIR("B")=$GET(COM)
+7 DO ^DIR
+8 SET COM=$SELECT('$DATA(DIRUT):Y,1:"")
+9 QUIT COM
+10 ; Ask for Fill Priority
APRTY ;EP-
+1 NEW DA,DIR
+2 SET DIR("A")="Fill Priority"
+3 SET DIR("B")=$$GET1^DIQ(9009033,PSOSITE,406)
+4 SET DIR(0)="52,9999999.38"
DO ^DIR
+5 SET APSPPRIO=$SELECT($LENGTH($GET(Y(0))):Y,1:"")
+6 QUIT
+7 ; Return status of Beyond Use field in 59.5
BYU(SITE) ;EP-
+1 QUIT +$SELECT('$GET(SITE):0,1:$GET(^PS(59.5,SITE,9999999)))
