APSPFUNC.m

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)