BEHORXFN ;MSC/IND/DKM/PLS - Supporting calls for EHR ;23-Jul-2015 21:20;PLS
;;1.1;BEH COMPONENTS;**009005,009006,009007,009008,009011,009012,009013**;Sep 18, 2007
;=================================================================
; RPC: BEHORXFN FINISH
; Finish a pending script
; DFN = Patient IEN
; ORIFN = Order IEN
; DATA returned as:
; Drug[1] ^ Rx #[2] ^ ExpDate[3] ^ RefRem[4] ^ Issue Date[5] ^ Status[6] ^
; Days Supply[7] ^ Quantity[8] ^ Provider IEN~Name[9] ^ PharmID[10] ^ OrderID[11] ^
; LastFill[12] ^ PharmSite[13] ^ NDC[14] ^ RXNORM[15] ^ Process State[16] ^ External Pharmacy[17]
; <"\" or " "><Instruction Text> where "\" indicates a new line
;
FINISH(DATA,DFN,ORIFN) ;
N PSIFN,X,RXINFO,I,ILST,INST
D CREATE^APSPFNC2(ORIFN,1)
S PSIFN=$$GETPSIFN(ORIFN)
S DATA=$$TMPGBL^CIAVMRPC
K @DATA
Q:'PSIFN
K ^TMP("PS",$J)
D OEL^PSOORRL(DFN,PSIFN)
S ILST=0
S RXINFO=$G(^TMP("PS",$J,0)),$P(RXINFO,U,2)=$P($G(^("RXN",0)),U)
S $P(RXINFO,U,9)=$TR($G(^TMP("PS",$J,"P",0)),U,"~")
S $P(RXINFO,U,10)=PSIFN_"R;O",$P(RXINFO,U,13)=$$LOC^APSPFNC2(+ORIFN)
S $P(RXINFO,U,14)=$$NDCVAL^APSPFUNC(PSIFN)
S $P(RXINFO,U,15)=$$GETRXNRM(+ORIFN,PSIFN)
S $P(RXINFO,U,16)=$$PSTATE(PSIFN)
S $P(RXINFO,U,17)=$$EPHARM(PSIFN)
D ADDOUT(RXINFO)
S INST(1)=" "_$P(RXINFO,U),Y=1
S:$L($P(RXINFO,U,8)) INST(1)=INST(1)_" Qty: "_$P(RXINFO,U,8)
S:$L($P(RXINFO,U,7)) INST(1)=INST(1)_" for "_$P(RXINFO,U,7)_" days"
S I=0
F S I=$O(^TMP("PS",$J,"SIG",I)) Q:'I D
.S Y=Y+1,INST(Y)=^TMP("PS",$J,"SIG",I,0)
S INST(2)="\ Sig: "_$G(INST(2))
F I=3:1:Y S INST(I)=" "_INST(I)
S I=0
F S I=+$O(INST(I)) Q:'I D ADDOUT(INST(I))
K ^TMP("PS",$J)
Q
; RPC: BEHORXFN PRINTLOG
; Log print activity
PRINTLOG(DATA,ORIFN,PRINTER,ACTION,COM) ;
N ARY,PSIFN
S:$L(PRINTER)>40 $E(PRINTER,1,$L(PRINTER)-37)="..."
S PRINTER=$TR(PRINTER,U)
I ACTION=2 D
.S ARY("COM")=$G(COM,"Comment not provided.")
.S ARY("TYPE")="R"
E D
.S ARY("COM")=$S(ACTION:"Sample label",1:"Prescription")_" printed on "_PRINTER_"."
.S ARY("TYPE")="P"
S ARY("REASON")="B"
S ARY("RX REF")=0
S ARY("DEV")=PRINTER
S:$L($G(COM)) ARY("COM")=COM
S PSIFN=+$$GETPSIFN(ORIFN)
I $$ORDFSIG(ORIFN) D
.D UPTLOG^BEHORXF1(.DATA,ORIFN,ACTION,.ARY)
E D:PSIFN UPTLOG^APSPFNC2(.DATA,PSIFN,ACTION,.ARY)
Q
; RPC: BEHORXFN GETRXS
; Fetch list of current prescriptions
; DFN = Patient IEN
; DAYS= # days to include in search (default = 365)
; DATA returned as a list in the format for each script:
;
; ~Type[1] ^ PharmID[2] ^ Drug[3] ^ InfRate[4] ^ StopDt[5] ^ RefRem[6] ^
; TotDose[7] ^ UnitDose[8] ^ OrderID[9] ^ Status[10] ^ LastFill[11] ^
; Days Supply[12] ^ Quantity[13] ^ Chronic[14] ^ Issued[15] ^
; Rx #[16] ^ Provider IEN~Name[17] ^ Status Reason[18] ^ DEA Handling[19] ^
; Pharmacy Site[20] ^ Indication ICD~Text[21] ^ DAW[22] ^ NVOA[23] ^ NDC[24] ^ RXNORM[25] ^
; Process State[26] ^ External Pharmacy[27]
;
; <"\" or " "><Instruction Text> where "\" indicates a new line
GETRXS(DATA,DFN,DAYS) ;
D CLNNVA
N INDEX,ILST,DAT
K ^TMP("PS",$J)
S:$G(DAYS)<1 DAYS=365
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
S ILST=0,INDEX=""
F S INDEX=$O(^TMP("PS",$J,INDEX),-1) Q:'INDEX D
.N INSTRUCT,COMMENTS,FIELDS,NVSDT,TYPE,IND,CMF,RXN,PRV,REASON,DEA,IFN,DAW,J,K,X,NDC,RXNORM,ATF,EPHARM,TDRUG
.S (INSTRUCT,COMMENTS,IND,CMF,RXN,REASON,DEA,DAW,NDC,RXNORM,ATF,EPHARM)=""
.S FIELDS=^TMP("PS",$J,INDEX,0),PRV=$TR($G(^("P",0)),U,"~")
.S IFN=+$P(FIELDS,U,8),X=$O(^OR(100,IFN,4.5,"ID","DRUG",0))
.S:X X=+$G(^OR(100,IFN,4.5,X,1))
.S:X DEA=$P($G(^PSDRUG(X,0)),U,3)
.;S:$D(^OR(100,IFN,8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,INDEX,0),U,2)
.S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
.I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV"
.S:$O(^TMP("PS",$J,INDEX,"A",0))>0 TYPE="IV"
.S:$O(^TMP("PS",$J,INDEX,"B",0))>0 TYPE="IV"
.Q:$G(IFN)&$D(^TMP("PS",$J,"X",TYPE,IFN)) S ^(IFN)="" ; OCL^PSOORRL can return dups
.I TYPE="UD" D
..D UDINST(.INSTRUCT)
..D SETMULT(.COMMENTS,"SIO")
..S TDRUG=$$VALUE^ORCSAVE2(IFN,"DRUG")
..S NDC=$$GET1^DIQ(50,TDRUG,31)
.E I TYPE="OP" D
..D OPINST(.INSTRUCT)
..S CMF=$$GETCMF1(IFN)
..S IND=$$GETIND(IFN)
..S DAW=$$GETDAW(IFN)
..S NDC=$$GETNDC(IFN)
..S RXNORM=$$GETRXNRM(IFN)
..S RXNORM=$P(RXNORM,U,1)
..S ATF=$$PSTATE(+$$GETPSIFN(IFN))
..S EPHARM=$$EPHARM(+$$GETPSIFN(IFN))
..S J=$P($P(FIELDS,U),";")
..I J["R" D
...S RXN=$P($G(^PSRX(+J,0)),U),J=$G(^(2)),K=+$G(^("STA"))
...;IHS/MSC/PLS - 09/30/2013
...;I K<12,'$P(J,U,13),$P(J,U,15) S $P(FIELDS,U,9,10)="Not Picked Up^",REASON="Returned to stock on "_$$FMTE^XLFDT($P(J,U,15))
...;I K=5 S $P(FIELDS,U,10)="" ;P1018 - remove last fill date for suspsended rxs
...I '$P(J,U,13),$P(J,U,15) D
....I K<12 S $P(FIELDS,U,9,10)="Not Picked Up^",REASON="Returned to stock on "_$$FMTE^XLFDT($P(J,U,15))
....E S $P(FIELDS,U,10)=""
...I "FESPQ"[ATF,ATF'="" S $P(FIELDS,U,10)="" ;IHS/MSC/PLS - 07/07/2015 - APSP 1019/EHR p15
.E I TYPE="IV" D
..D IVINST(.INSTRUCT)
..D SETMULT(.COMMENTS,"SIO")
.E I TYPE="NV" D
..D NVINST(.INSTRUCT)
..D NVSTATE(.REASON,.NVSDT)
..D SETMULT(.COMMENTS,"SIO")
..S $P(FIELDS,U,9)=$$NVSTS(IFN,$P(FIELDS,U,9))
..S $P(FIELDS,U,15)=$G(NVSDT)
..S TDRUG=$$VALUE^ORCSAVE2(IFN,"DRUG")
..S NDC=$$GET1^DIQ(50,TDRUG,31)
.S:$D(COMMENTS(1)) COMMENTS(1)="\"_COMMENTS(1)
.S:$P(FIELDS,U,9)="HOLD" REASON=$$HLDRSN(IFN)
.D ADDOUT("~"_TYPE_U_$P(FIELDS,U,1,12)_U_CMF_U_$P(FIELDS,U,15)_U_RXN_U_PRV_U_REASON_U_DEA_U_$S(IFN:$$LOC^APSPFNC2(IFN),1:"")_U_IND_U_DAW_U_$$NVOA()_U_NDC_U_RXNORM_U_ATF_U_EPHARM)
.S J=0
.F S J=+$O(INSTRUCT(J)) Q:'J D ADDOUT(INSTRUCT(J))
.F S J=+$O(COMMENTS(J)) Q:'J D ADDOUT("t"_COMMENTS(J))
.F S J=+$O(REASON(J)) Q:'J D ADDOUT("t"_REASON(J))
K ^TMP("PS",$J)
Q
; Add to output
ADDOUT(X) ;
S ILST=ILST+1,@DATA@(ILST)=X
Q
; Assembles instructions for a unit dose order
UDINST(Y) ;
N I,X
S X=FIELDS
S Y(1)=" "_$P(X,U,2),Y=1
S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
I $L(X) S Y=2,Y(2)=X
E S Y=1 D SETMULT(.Y,"SIG")
S Y(2)="\Give: "_$G(Y(2)),Y=$G(Y,2)
D SETMULT(.Y,"MDR"),SETMULT(.Y,"SCH")
F I=3:1:Y S Y(I)=" "_Y(I)
Q
; Assembles instructions for an outpatient prescription
OPINST(Y) ;
N I,X
S X=FIELDS
S Y(1)=" "_$P(X,U,2),Y=1
S:$L($P(X,U,12)) Y(1)=Y(1)_" Qty: "_$P(X,U,12)
S:$L($P(X,U,11)) Y(1)=Y(1)_" for "_$P(X,U,11)_" days"
D SETMULT(.Y,"SIG")
I Y=1 D
.D SETMULT(.Y,"SIO")
.D SETMULT(.Y,"MDR")
.D SETMULT(.Y,"SCH")
S Y(2)="\ Sig: "_$G(Y(2))
F I=3:1:Y S Y(I)=" "_Y(I)
Q
; Assembles instructions for an IV order
IVINST(Y) ;
N SOLN1,I
S Y=0
D SETMULT(.Y,"A")
S SOLN1=Y+1
D SETMULT(.Y,"B")
I $D(Y(SOLN1)),$L($P(FIELDS,U,2)) S Y(SOLN1)="in "_Y(SOLN1)
S SOLN1=Y+1
D SETMULT(.Y,"SCH")
S:$D(Y(SOLN1)) Y(SOLN1)=" "_Y(SOLN1)
F I=1:1:Y S Y(I)="\"_$TR(Y(I),U," ")
S:$D(Y(1)) Y(1)=" "_$E(Y(1),2,999)
S Y(Y)=Y(Y)_" "_$P(FIELDS,U,3)
Q
; Assembles instructions for a home med
NVINST(Y) ;
N I
S Y(1)=" "_$P(FIELDS,U,2),Y=1
D SETMULT(.Y,"SIG")
I Y=1 D
.D SETMULT(.Y,"SIO")
.D SETMULT(.Y,"MDR")
.D SETMULT(.Y,"SCH")
S Y(2)="\ "_$G(Y(2))
F I=3:1:Y S Y(I)=" "_Y(I)
Q
; Assembles start date and reasons for a home med
NVSTATE(Y,NVSDT) ;
N ORN
S ORN=+$P(FIELDS,U,8)
I $D(^OR(100,ORN,0)) D
.S NVSDT=$P(^OR(100,ORN,0),U,8)
.D WPVAL(.Y,ORN,"STATEMENTS")
Q
; Return Non-VA med validate order action
NVOA() ;EP -
N ORN,OA
S ORN=+$P(FIELDS,U,8)
S OA=$P($G(^OR(100,ORN,8,1,0)),U,2)
Q $S(OA="VA":OA,1:"")
; Return status for home med
NVSTS(IFN,STS) ;EP -
N OSTS
S OSTS=$$GET1^DIQ(100,IFN,5,"I")
Q $S((OSTS>21399)!(OSTS=3):$$GET1^DIQ(100.01,OSTS,.01),1:STS)
; Return word processing value
WPVAL(Y,ORN,ID) ;
N DA,I,J
S DA=+$O(^OR(100,ORN,4.5,"ID",ID,0)),(I,J)=0
F S I=$O(^OR(100,ORN,4.5,DA,2,I)) Q:'I S J=J+1,Y(J)=^(I,0)
Q
; Appends the multiple at the subscript to Y
SETMULT(Y,SUB) ;
N I
S I=0
F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I D
.S Y=Y+1,Y(Y)=^TMP("PS",$J,INDEX,SUB,I,0)
Q
; Return hold reason
HLDRSN(ORIFN) ;
N RSN,PSIFN,X
S X=$O(^OR(100,+ORIFN,8,"C","HD",""),-1)
S:$O(^OR(100,+ORIFN,8,"C","RL",X)) X=""
S RSN=$S('X:"",1:$G(^OR(100,+ORIFN,8,X,1)))
S PSIFN=$$GETPSIFN(ORIFN)
I PSIFN=+PSIFN D
.S X=$$GET1^DIQ(52,PSIFN,99.1)
.S:'$L(X) X=$$GET1^DIQ(52,PSIFN,99),X=$S($E(X,1,5)="OTHER":"",1:X)
.S:$L(X) RSN=X
Q "Hold Reason: "_$S($L(RSN):RSN,1:"Not specified")
; Return chronic med flag from order IFN
GETCMF1(ORIFN) ;EP
N PSIFN
S PSIFN=$$GETPSIFN(ORIFN)
Q:PSIFN=+PSIFN $$GET1^DIQ(52,PSIFN,9999999.02)["Y"
Q $$VALUE^ORCSAVE2(+ORIFN,"CMF")["Y"
; Return clinical indication from order IFN
GETIND(ORIFN) ;EP
N PSIFN,ICD,TXT
S PSIFN=$$GETPSIFN(ORIFN)
I PSIFN=+PSIFN D
.S TXT=$$GET1^DIQ(52,PSIFN,9999999.21)
.S ICD=$$GET1^DIQ(52,PSIFN,9999999.22)
E D
.S TXT=$$VALUE^ORCSAVE2(+ORIFN,"CLININD")
.S ICD=$$VALUE^ORCSAVE2(+ORIFN,"CLININD2")
Q $S($L(TXT)!$L(ICD):ICD_"~"_TXT,1:"")
; Return dispense as written (DAW) flag from order IFN
GETDAW(ORIFN) ;EP
N PSIFN,DAW
S PSIFN=$$GETPSIFN(ORIFN)
I PSIFN=+PSIFN S DAW=$$GET1^DIQ(52,PSIFN,9999999.25,"I")
E S DAW=$$VALUE^ORCSAVE2(+ORIFN,"DAW")
Q $S(DAW=7:1,DAW>1:0,1:+DAW)
; Return NDC value associated with Prescription
GETNDC(ORIFN) ;EP
N PSIFN,NDC
S NDC=""
S PSIFN=$$GETPSIFN(ORIFN)
S:PSIFN=+PSIFN NDC=$$NDCVAL^APSPFUNC(PSIFN)
Q NDC
; Return RXNORM value associated with NDC
GETRXNRM(ORIFN,PSIFN) ;EP
N RXNORM,NDC,DRUG
S RXNORM=""
S PSIFN=$G(PSIFN,$$GETPSIFN(ORIFN))
I PSIFN=+PSIFN D
.;EHR 13 changes made to get Rxnorm from prescription
.S RXNORM=$$GET1^DIQ(52,PSIFN,9999999.27,"I")
.;S NDC=$TR($$NDCVAL^APSPFUNC(PSIFN),"-","")
.;Q:'$L(NDC)
.;S RXNORM=+$O(^C0CRXN(176.002,"NDC",NDC,0))
.;S RXNORM=$$GET1^DIQ(176.002,RXNORM,.01)
Q RXNORM
; Return process state of E, Q, P, or I
PSTATE(PSIFN) ;EP-
N RES,ATF,PMY,PRT,LACT
S RES=""
S ATF=$$GET1^DIQ(52,PSIFN,9999999.23,"I") ;autofinish
S PMY=$$GET1^DIQ(52,PSIFN,9999999.24,"I") ;pharmacy
I 'ATF S RES="I"
E D
.S PRT=$$CKRXACT^APSPFNC6(PSIFN,"B","PR")
.I PMY D
..; if pharmacy and either transmitted or failed to transmit and no print then return E
..; else
..I $$CKRXACT^APSPFNC6(PSIFN,"X","T")!($$CKRXACT^APSPFNC6(PSIFN,"X","F"))!($$CKRXACT^APSPFNC6(PSIFN,"X","U"))&('PRT) D ;S RES="E"
...;I 'PRT D
...S LACT=$$LASTACT^APSPFNC6(PSIFN,"X")
...S RES=$S(LACT="F":"F",LACT="T":"E",LACT="X":"E",LACT="U":"S",1:"")
..E S RES=$S(PRT:"P",1:"Q")
.E D
..S RES=$S(PRT:"P",1:"Q")
Q RES
; Return external pharmacy information
EPHARM(PSIFN) ;EP-
Q $$GET1^DIQ(52,PSIFN,9999999.24,"I")_";"_$$GET1^DIQ(52,PSIFN,9999999.24)
; Get pharmacy IFN from order IFN
GETPSIFN(ORIFN) ;
N PKG,PSIFN
S PKG=+$P($G(^OR(100,+ORIFN,0)),U,14),PSIFN=$P($G(^(4)),U)
Q $S('PSIFN!(PKG'=$O(^DIC(9.4,"C","PSO",0))):"",1:PSIFN)
; RPC: BEHORXFN SETCMF
; Set chronic med flag for one or more prescriptions
; DFN = Patient IEN
; RXS = Order ID or list of order IDs
; CMF = New value for chronic med flag (0 or 1)
; DATA returned as list in format:
; OrderID^Error Text (null if no error)
SETCMF(DATA,DFN,RXS,CMF) ;EP
N LP,FDA,FDX,ERR,PLC,ORIFN,IDS,X
S:$L($G(RXS)) RXS(-1)=RXS
S LP="",PLC=0
F S LP=$O(RXS(LP)) Q:'$L(LP) D SETCMF1(RXS(LP))
D:$D(FDA) UPDATE^DIE("E","FDA",,"ERR")
F S LP=$O(ERR("DIERR",LP)) Q:'LP D
.S ORIFN=FDX($G(ERR("DIERR",LP,"PARAM","FILE"),100.045),ERR("DIERR",LP,"PARAM","IENS"))
.D ADDERR(ERR("DIERR",LP,"TEXT",1))
Q
; Set CMF flag in FDA array for specified order and associated script
SETCMF1(ORIFN) ;
N PSIFN,OK
S IDS(ORIFN)=LP,DATA(LP)=ORIFN
I $P($G(^OR(100,+ORIFN,0)),U,2)'=(DFN_";DPT(") D Q
.D ADDERR("Prescription does not belong to current patient.")
S PSIFN=$$GETPSIFN(ORIFN)
D:PSIFN=+PSIFN ADDFDA(52,PSIFN_",",9999999.02) ; Set CMF on script
S OK=+$O(^OR(100,+ORIFN,4.5,"ID","CMF",0)) ; Find CMF prompt on order
I OK D ; If prompt found, change response
.D ADDFDA(100.045,OK_","_+ORIFN_",",1)
E D ; Else add prompt and set response
.N X,DLG,PMT,CMI,CMN,IENS
.S DLG=$P($G(^OR(100,+ORIFN,0)),U,5)
.Q:DLG'[";ORD(101.41,"
.S DLG=+DLG,CMI=+$O(^ORD(101.41,"B","OR GTX CMF",0))
.S CMN=$O(^ORD(101.41,DLG,10,"D",CMI,0))
.Q:'CMN
.S PLC=PLC+1,IENS="+"_PLC_","_+ORIFN_",",OK=1
.S FDA(100.045,IENS,.01)=CMN
.S FDA(100.045,IENS,.02)="`"_CMI
.S FDA(100.045,IENS,.03)=1
.S FDA(100.045,IENS,.04)="CMF"
.D ADDFDA(100.045,IENS,1)
D:'OK ADDERR("Cannot set chronic med status on this order.")
Q
; Add to FDA array
ADDFDA(FN,IENS,FLD) ;
S FDA(FN,IENS,FLD)=$S(CMF:"Y",1:"N"),FDX(FN,IENS)=ORIFN
Q
; Add error text
ADDERR(TXT) ;
S DATA(IDS(ORIFN))=ORIFN_U_TXT
Q
; Get list of active/pending med orders for order checking
OCALL(DATA,DFN) ;EP
N CNT,OBJ,ORIEN,ORLOG,X,ST
S OBJ=DFN_";DPT(",(CNT,ORLOG)=0,DATA=$$TMPGBL^CIAVMRPC
F S ORLOG=$O(^OR(100,"AC",OBJ,ORLOG)) Q:'ORLOG D
.S ORIEN=0
.F S ORIEN=$O(^OR(100,"AC",OBJ,ORLOG,ORIEN)) Q:'ORIEN D
..Q:$D(@DATA@(0,ORIEN))
..S @DATA@(0,ORIEN)=""
..S X=$G(^OR(100,ORIEN,0)),ST=$P($G(^(3)),U,3)
..I ST'=5,ST'=6,ST'=11 Q
..Q:$P(X,U,2)'=OBJ
..S PKG=$$GET1^DIQ(9.4,$P(X,U,14),1)
..Q:$E(PKG,1,2)'="PS"
..S CNT=CNT+1,@DATA@(CNT)=ORIEN
K @DATA@(0)
Q
; Cleanup PCC Link in NVA node
CLNNVA ;EP -
Q:$$PATCH^XPDUTL("APSP*7.0*1009")
N DFN,IEN,FDA,NVAERR
S DFN=0 F S DFN=$O(^PS(55,"APCC","+1",DFN)) Q:'DFN D
.S IEN=0 F S IEN=$O(^PS(55,"APCC","+1",DFN,IEN)) Q:'IEN D
..S FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
D:$D(FDA) UPDATE^DIE("","FDA",,"NVAERR")
Q
; Returns boolean flag indicating if order is Order For Signature
ORDFSIG(ORIFN) ;EP-
N ORD
S ORD=$G(^OR(100,ORIFN,4))
Q (ORD?.N1"S")&($P($G(^OR(100,ORIFN,3)),U,3)=5)
; Returns string containing vital measurement
; Date/time^Imperial value^Metric value
VITALFMT(DATA,DFN,TYP) ;EP-
S DATA=""
Q:'$G(DFN)
Q:'$L($G(TYP))
S DATA=$$VITALF^APSPFUNC(DFN,TYP)
S DATA=$P(DATA,U)_U_$P(DATA,U,8,9)
Q
BEHORXFN ;MSC/IND/DKM/PLS - Supporting calls for EHR ;23-Jul-2015 21:20;PLS
+1 ;;1.1;BEH COMPONENTS;**009005,009006,009007,009008,009011,009012,009013**;Sep 18, 2007
+2 ;=================================================================
+3 ; RPC: BEHORXFN FINISH
+4 ; Finish a pending script
+5 ; DFN = Patient IEN
+6 ; ORIFN = Order IEN
+7 ; DATA returned as:
+8 ; Drug[1] ^ Rx #[2] ^ ExpDate[3] ^ RefRem[4] ^ Issue Date[5] ^ Status[6] ^
+9 ; Days Supply[7] ^ Quantity[8] ^ Provider IEN~Name[9] ^ PharmID[10] ^ OrderID[11] ^
+10 ; LastFill[12] ^ PharmSite[13] ^ NDC[14] ^ RXNORM[15] ^ Process State[16] ^ External Pharmacy[17]
+11 ; <"\" or " "><Instruction Text> where "\" indicates a new line
+12 ;
FINISH(DATA,DFN,ORIFN) ;
+1 NEW PSIFN,X,RXINFO,I,ILST,INST
+2 DO CREATE^APSPFNC2(ORIFN,1)
+3 SET PSIFN=$$GETPSIFN(ORIFN)
+4 SET DATA=$$TMPGBL^CIAVMRPC
+5 KILL @DATA
+6 IF 'PSIFN
QUIT
+7 KILL ^TMP("PS",$JOB)
+8 DO OEL^PSOORRL(DFN,PSIFN)
+9 SET ILST=0
+10 SET RXINFO=$GET(^TMP("PS",$JOB,0))
SET $PIECE(RXINFO,U,2)=$PIECE($GET(^("RXN",0)),U)
+11 SET $PIECE(RXINFO,U,9)=$TRANSLATE($GET(^TMP("PS",$JOB,"P",0)),U,"~")
+12 SET $PIECE(RXINFO,U,10)=PSIFN_"R;O"
SET $PIECE(RXINFO,U,13)=$$LOC^APSPFNC2(+ORIFN)
+13 SET $PIECE(RXINFO,U,14)=$$NDCVAL^APSPFUNC(PSIFN)
+14 SET $PIECE(RXINFO,U,15)=$$GETRXNRM(+ORIFN,PSIFN)
+15 SET $PIECE(RXINFO,U,16)=$$PSTATE(PSIFN)
+16 SET $PIECE(RXINFO,U,17)=$$EPHARM(PSIFN)
+17 DO ADDOUT(RXINFO)
+18 SET INST(1)=" "_$PIECE(RXINFO,U)
SET Y=1
+19 IF $LENGTH($PIECE(RXINFO,U,8))
SET INST(1)=INST(1)_" Qty: "_$PIECE(RXINFO,U,8)
+20 IF $LENGTH($PIECE(RXINFO,U,7))
SET INST(1)=INST(1)_" for "_$PIECE(RXINFO,U,7)_" days"
+21 SET I=0
+22 FOR
SET I=$ORDER(^TMP("PS",$JOB,"SIG",I))
IF 'I
QUIT
Begin DoDot:1
+23 SET Y=Y+1
SET INST(Y)=^TMP("PS",$JOB,"SIG",I,0)
End DoDot:1
+24 SET INST(2)="\ Sig: "_$GET(INST(2))
+25 FOR I=3:1:Y
SET INST(I)=" "_INST(I)
+26 SET I=0
+27 FOR
SET I=+$ORDER(INST(I))
IF 'I
QUIT
DO ADDOUT(INST(I))
+28 KILL ^TMP("PS",$JOB)
+29 QUIT
+30 ; RPC: BEHORXFN PRINTLOG
+31 ; Log print activity
PRINTLOG(DATA,ORIFN,PRINTER,ACTION,COM) ;
+1 NEW ARY,PSIFN
+2 IF $LENGTH(PRINTER)>40
SET $EXTRACT(PRINTER,1,$LENGTH(PRINTER)-37)="..."
+3 SET PRINTER=$TRANSLATE(PRINTER,U)
+4 IF ACTION=2
Begin DoDot:1
+5 SET ARY("COM")=$GET(COM,"Comment not provided.")
+6 SET ARY("TYPE")="R"
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET ARY("COM")=$SELECT(ACTION:"Sample label",1:"Prescription")_" printed on "_PRINTER_"."
+9 SET ARY("TYPE")="P"
End DoDot:1
+10 SET ARY("REASON")="B"
+11 SET ARY("RX REF")=0
+12 SET ARY("DEV")=PRINTER
+13 IF $LENGTH($GET(COM))
SET ARY("COM")=COM
+14 SET PSIFN=+$$GETPSIFN(ORIFN)
+15 IF $$ORDFSIG(ORIFN)
Begin DoDot:1
+16 DO UPTLOG^BEHORXF1(.DATA,ORIFN,ACTION,.ARY)
End DoDot:1
+17 IF '$TEST
IF PSIFN
DO UPTLOG^APSPFNC2(.DATA,PSIFN,ACTION,.ARY)
+18 QUIT
+19 ; RPC: BEHORXFN GETRXS
+20 ; Fetch list of current prescriptions
+21 ; DFN = Patient IEN
+22 ; DAYS= # days to include in search (default = 365)
+23 ; DATA returned as a list in the format for each script:
+24 ;
+25 ; ~Type[1] ^ PharmID[2] ^ Drug[3] ^ InfRate[4] ^ StopDt[5] ^ RefRem[6] ^
+26 ; TotDose[7] ^ UnitDose[8] ^ OrderID[9] ^ Status[10] ^ LastFill[11] ^
+27 ; Days Supply[12] ^ Quantity[13] ^ Chronic[14] ^ Issued[15] ^
+28 ; Rx #[16] ^ Provider IEN~Name[17] ^ Status Reason[18] ^ DEA Handling[19] ^
+29 ; Pharmacy Site[20] ^ Indication ICD~Text[21] ^ DAW[22] ^ NVOA[23] ^ NDC[24] ^ RXNORM[25] ^
+30 ; Process State[26] ^ External Pharmacy[27]
+31 ;
+32 ; <"\" or " "><Instruction Text> where "\" indicates a new line
GETRXS(DATA,DFN,DAYS) ;
+1 DO CLNNVA
+2 NEW INDEX,ILST,DAT
+3 KILL ^TMP("PS",$JOB)
+4 IF $GET(DAYS)<1
SET DAYS=365
+5 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
+6 SET ILST=0
SET INDEX=""
+7 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX),-1)
IF 'INDEX
QUIT
Begin DoDot:1
+8 NEW INSTRUCT,COMMENTS,FIELDS,NVSDT,TYPE,IND,CMF,RXN,PRV,REASON,DEA,IFN,DAW,J,K,X,NDC,RXNORM,ATF,EPHARM,TDRUG
+9 SET (INSTRUCT,COMMENTS,IND,CMF,RXN,REASON,DEA,DAW,NDC,RXNORM,ATF,EPHARM)=""
+10 SET FIELDS=^TMP("PS",$JOB,INDEX,0)
SET PRV=$TRANSLATE($GET(^("P",0)),U,"~")
+11 SET IFN=+$PIECE(FIELDS,U,8)
SET X=$ORDER(^OR(100,IFN,4.5,"ID","DRUG",0))
+12 IF X
SET X=+$GET(^OR(100,IFN,4.5,X,1))
+13 IF X
SET DEA=$PIECE($GET(^PSDRUG(X,0)),U,3)
+14 ;S:$D(^OR(100,IFN,8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,INDEX,0),U,2)
+15 SET TYPE=$SELECT($PIECE($PIECE(FIELDS,U),";",2)="O":"OP",1:"UD")
+16 IF TYPE="OP"
IF $PIECE(FIELDS,";")["N"
SET TYPE="NV"
+17 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+18 IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+19 ; OCL^PSOORRL can return dups
IF $GET(IFN)&$DATA(^TMP("PS",$JOB,"X",TYPE,IFN))
QUIT
SET ^(IFN)=""
+20 IF TYPE="UD"
Begin DoDot:2
+21 DO UDINST(.INSTRUCT)
+22 DO SETMULT(.COMMENTS,"SIO")
+23 SET TDRUG=$$VALUE^ORCSAVE2(IFN,"DRUG")
+24 SET NDC=$$GET1^DIQ(50,TDRUG,31)
End DoDot:2
+25 IF '$TEST
IF TYPE="OP"
Begin DoDot:2
+26 DO OPINST(.INSTRUCT)
+27 SET CMF=$$GETCMF1(IFN)
+28 SET IND=$$GETIND(IFN)
+29 SET DAW=$$GETDAW(IFN)
+30 SET NDC=$$GETNDC(IFN)
+31 SET RXNORM=$$GETRXNRM(IFN)
+32 SET RXNORM=$PIECE(RXNORM,U,1)
+33 SET ATF=$$PSTATE(+$$GETPSIFN(IFN))
+34 SET EPHARM=$$EPHARM(+$$GETPSIFN(IFN))
+35 SET J=$PIECE($PIECE(FIELDS,U),";")
+36 IF J["R"
Begin DoDot:3
+37 SET RXN=$PIECE($GET(^PSRX(+J,0)),U)
SET J=$GET(^(2))
SET K=+$GET(^("STA"))
+38 ;IHS/MSC/PLS - 09/30/2013
+39 ;I K<12,'$P(J,U,13),$P(J,U,15) S $P(FIELDS,U,9,10)="Not Picked Up^",REASON="Returned to stock on "_$$FMTE^XLFDT($P(J,U,15))
+40 ;I K=5 S $P(FIELDS,U,10)="" ;P1018 - remove last fill date for suspsended rxs
+41 IF '$PIECE(J,U,13)
IF $PIECE(J,U,15)
Begin DoDot:4
+42 IF K<12
SET $PIECE(FIELDS,U,9,10)="Not Picked Up^"
SET REASON="Returned to stock on "_$$FMTE^XLFDT($PIECE(J,U,15))
+43 IF '$TEST
SET $PIECE(FIELDS,U,10)=""
End DoDot:4
+44 ;IHS/MSC/PLS - 07/07/2015 - APSP 1019/EHR p15
IF "FESPQ"[ATF
IF ATF'=""
SET $PIECE(FIELDS,U,10)=""
End DoDot:3
End DoDot:2
+45 IF '$TEST
IF TYPE="IV"
Begin DoDot:2
+46 DO IVINST(.INSTRUCT)
+47 DO SETMULT(.COMMENTS,"SIO")
End DoDot:2
+48 IF '$TEST
IF TYPE="NV"
Begin DoDot:2
+49 DO NVINST(.INSTRUCT)
+50 DO NVSTATE(.REASON,.NVSDT)
+51 DO SETMULT(.COMMENTS,"SIO")
+52 SET $PIECE(FIELDS,U,9)=$$NVSTS(IFN,$PIECE(FIELDS,U,9))
+53 SET $PIECE(FIELDS,U,15)=$GET(NVSDT)
+54 SET TDRUG=$$VALUE^ORCSAVE2(IFN,"DRUG")
+55 SET NDC=$$GET1^DIQ(50,TDRUG,31)
End DoDot:2
+56 IF $DATA(COMMENTS(1))
SET COMMENTS(1)="\"_COMMENTS(1)
+57 IF $PIECE(FIELDS,U,9)="HOLD"
SET REASON=$$HLDRSN(IFN)
+58 DO ADDOUT("~"_TYPE_U_$PIECE(FIELDS,U,1,12)_U_CMF_U_$PIECE(FIELDS,U,15)_U_RXN_U_PRV_U_REASON_U_DEA_U_$SELECT(IFN:$$LOC^APSPFNC2(IFN),1:"")_U_IND_U_DAW_U_$$NVOA()_U_NDC_U_RXNORM_U_ATF_U_EPHARM)
+59 SET J=0
+60 FOR
SET J=+$ORDER(INSTRUCT(J))
IF 'J
QUIT
DO ADDOUT(INSTRUCT(J))
+61 FOR
SET J=+$ORDER(COMMENTS(J))
IF 'J
QUIT
DO ADDOUT("t"_COMMENTS(J))
+62 FOR
SET J=+$ORDER(REASON(J))
IF 'J
QUIT
DO ADDOUT("t"_REASON(J))
End DoDot:1
+63 KILL ^TMP("PS",$JOB)
+64 QUIT
+65 ; Add to output
ADDOUT(X) ;
+1 SET ILST=ILST+1
SET @DATA@(ILST)=X
+2 QUIT
+3 ; Assembles instructions for a unit dose order
UDINST(Y) ;
+1 NEW I,X
+2 SET X=FIELDS
+3 SET Y(1)=" "_$PIECE(X,U,2)
SET Y=1
+4 SET X=$SELECT($LENGTH($PIECE(X,U,6)):$PIECE(X,U,6),1:$PIECE(X,U,7))
+5 IF $LENGTH(X)
SET Y=2
SET Y(2)=X
+6 IF '$TEST
SET Y=1
DO SETMULT(.Y,"SIG")
+7 SET Y(2)="\Give: "_$GET(Y(2))
SET Y=$GET(Y,2)
+8 DO SETMULT(.Y,"MDR")
DO SETMULT(.Y,"SCH")
+9 FOR I=3:1:Y
SET Y(I)=" "_Y(I)
+10 QUIT
+11 ; Assembles instructions for an outpatient prescription
OPINST(Y) ;
+1 NEW I,X
+2 SET X=FIELDS
+3 SET Y(1)=" "_$PIECE(X,U,2)
SET Y=1
+4 IF $LENGTH($PIECE(X,U,12))
SET Y(1)=Y(1)_" Qty: "_$PIECE(X,U,12)
+5 IF $LENGTH($PIECE(X,U,11))
SET Y(1)=Y(1)_" for "_$PIECE(X,U,11)_" days"
+6 DO SETMULT(.Y,"SIG")
+7 IF Y=1
Begin DoDot:1
+8 DO SETMULT(.Y,"SIO")
+9 DO SETMULT(.Y,"MDR")
+10 DO SETMULT(.Y,"SCH")
End DoDot:1
+11 SET Y(2)="\ Sig: "_$GET(Y(2))
+12 FOR I=3:1:Y
SET Y(I)=" "_Y(I)
+13 QUIT
+14 ; Assembles instructions for an IV order
IVINST(Y) ;
+1 NEW SOLN1,I
+2 SET Y=0
+3 DO SETMULT(.Y,"A")
+4 SET SOLN1=Y+1
+5 DO SETMULT(.Y,"B")
+6 IF $DATA(Y(SOLN1))
IF $LENGTH($PIECE(FIELDS,U,2))
SET Y(SOLN1)="in "_Y(SOLN1)
+7 SET SOLN1=Y+1
+8 DO SETMULT(.Y,"SCH")
+9 IF $DATA(Y(SOLN1))
SET Y(SOLN1)=" "_Y(SOLN1)
+10 FOR I=1:1:Y
SET Y(I)="\"_$TRANSLATE(Y(I),U," ")
+11 IF $DATA(Y(1))
SET Y(1)=" "_$EXTRACT(Y(1),2,999)
+12 SET Y(Y)=Y(Y)_" "_$PIECE(FIELDS,U,3)
+13 QUIT
+14 ; Assembles instructions for a home med
NVINST(Y) ;
+1 NEW I
+2 SET Y(1)=" "_$PIECE(FIELDS,U,2)
SET Y=1
+3 DO SETMULT(.Y,"SIG")
+4 IF Y=1
Begin DoDot:1
+5 DO SETMULT(.Y,"SIO")
+6 DO SETMULT(.Y,"MDR")
+7 DO SETMULT(.Y,"SCH")
End DoDot:1
+8 SET Y(2)="\ "_$GET(Y(2))
+9 FOR I=3:1:Y
SET Y(I)=" "_Y(I)
+10 QUIT
+11 ; Assembles start date and reasons for a home med
NVSTATE(Y,NVSDT) ;
+1 NEW ORN
+2 SET ORN=+$PIECE(FIELDS,U,8)
+3 IF $DATA(^OR(100,ORN,0))
Begin DoDot:1
+4 SET NVSDT=$PIECE(^OR(100,ORN,0),U,8)
+5 DO WPVAL(.Y,ORN,"STATEMENTS")
End DoDot:1
+6 QUIT
+7 ; Return Non-VA med validate order action
NVOA() ;EP -
+1 NEW ORN,OA
+2 SET ORN=+$PIECE(FIELDS,U,8)
+3 SET OA=$PIECE($GET(^OR(100,ORN,8,1,0)),U,2)
+4 QUIT $SELECT(OA="VA":OA,1:"")
+5 ; Return status for home med
NVSTS(IFN,STS) ;EP -
+1 NEW OSTS
+2 SET OSTS=$$GET1^DIQ(100,IFN,5,"I")
+3 QUIT $SELECT((OSTS>21399)!(OSTS=3):$$GET1^DIQ(100.01,OSTS,.01),1:STS)
+4 ; Return word processing value
WPVAL(Y,ORN,ID) ;
+1 NEW DA,I,J
+2 SET DA=+$ORDER(^OR(100,ORN,4.5,"ID",ID,0))
SET (I,J)=0
+3 FOR
SET I=$ORDER(^OR(100,ORN,4.5,DA,2,I))
IF 'I
QUIT
SET J=J+1
SET Y(J)=^(I,0)
+4 QUIT
+5 ; Appends the multiple at the subscript to Y
SETMULT(Y,SUB) ;
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(^TMP("PS",$JOB,INDEX,SUB,I))
IF 'I
QUIT
Begin DoDot:1
+4 SET Y=Y+1
SET Y(Y)=^TMP("PS",$JOB,INDEX,SUB,I,0)
End DoDot:1
+5 QUIT
+6 ; Return hold reason
HLDRSN(ORIFN) ;
+1 NEW RSN,PSIFN,X
+2 SET X=$ORDER(^OR(100,+ORIFN,8,"C","HD",""),-1)
+3 IF $ORDER(^OR(100,+ORIFN,8,"C","RL",X))
SET X=""
+4 SET RSN=$SELECT('X:"",1:$GET(^OR(100,+ORIFN,8,X,1)))
+5 SET PSIFN=$$GETPSIFN(ORIFN)
+6 IF PSIFN=+PSIFN
Begin DoDot:1
+7 SET X=$$GET1^DIQ(52,PSIFN,99.1)
+8 IF '$LENGTH(X)
SET X=$$GET1^DIQ(52,PSIFN,99)
SET X=$SELECT($EXTRACT(X,1,5)="OTHER":"",1:X)
+9 IF $LENGTH(X)
SET RSN=X
End DoDot:1
+10 QUIT "Hold Reason: "_$SELECT($LENGTH(RSN):RSN,1:"Not specified")
+11 ; Return chronic med flag from order IFN
GETCMF1(ORIFN) ;EP
+1 NEW PSIFN
+2 SET PSIFN=$$GETPSIFN(ORIFN)
+3 IF PSIFN=+PSIFN
QUIT $$GET1^DIQ(52,PSIFN,9999999.02)["Y"
+4 QUIT $$VALUE^ORCSAVE2(+ORIFN,"CMF")["Y"
+5 ; Return clinical indication from order IFN
GETIND(ORIFN) ;EP
+1 NEW PSIFN,ICD,TXT
+2 SET PSIFN=$$GETPSIFN(ORIFN)
+3 IF PSIFN=+PSIFN
Begin DoDot:1
+4 SET TXT=$$GET1^DIQ(52,PSIFN,9999999.21)
+5 SET ICD=$$GET1^DIQ(52,PSIFN,9999999.22)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET TXT=$$VALUE^ORCSAVE2(+ORIFN,"CLININD")
+8 SET ICD=$$VALUE^ORCSAVE2(+ORIFN,"CLININD2")
End DoDot:1
+9 QUIT $SELECT($LENGTH(TXT)!$LENGTH(ICD):ICD_"~"_TXT,1:"")
+10 ; Return dispense as written (DAW) flag from order IFN
GETDAW(ORIFN) ;EP
+1 NEW PSIFN,DAW
+2 SET PSIFN=$$GETPSIFN(ORIFN)
+3 IF PSIFN=+PSIFN
SET DAW=$$GET1^DIQ(52,PSIFN,9999999.25,"I")
+4 IF '$TEST
SET DAW=$$VALUE^ORCSAVE2(+ORIFN,"DAW")
+5 QUIT $SELECT(DAW=7:1,DAW>1:0,1:+DAW)
+6 ; Return NDC value associated with Prescription
GETNDC(ORIFN) ;EP
+1 NEW PSIFN,NDC
+2 SET NDC=""
+3 SET PSIFN=$$GETPSIFN(ORIFN)
+4 IF PSIFN=+PSIFN
SET NDC=$$NDCVAL^APSPFUNC(PSIFN)
+5 QUIT NDC
+6 ; Return RXNORM value associated with NDC
GETRXNRM(ORIFN,PSIFN) ;EP
+1 NEW RXNORM,NDC,DRUG
+2 SET RXNORM=""
+3 SET PSIFN=$GET(PSIFN,$$GETPSIFN(ORIFN))
+4 IF PSIFN=+PSIFN
Begin DoDot:1
+5 ;EHR 13 changes made to get Rxnorm from prescription
+6 SET RXNORM=$$GET1^DIQ(52,PSIFN,9999999.27,"I")
+7 ;S NDC=$TR($$NDCVAL^APSPFUNC(PSIFN),"-","")
+8 ;Q:'$L(NDC)
+9 ;S RXNORM=+$O(^C0CRXN(176.002,"NDC",NDC,0))
+10 ;S RXNORM=$$GET1^DIQ(176.002,RXNORM,.01)
End DoDot:1
+11 QUIT RXNORM
+12 ; Return process state of E, Q, P, or I
PSTATE(PSIFN) ;EP-
+1 NEW RES,ATF,PMY,PRT,LACT
+2 SET RES=""
+3 ;autofinish
SET ATF=$$GET1^DIQ(52,PSIFN,9999999.23,"I")
+4 ;pharmacy
SET PMY=$$GET1^DIQ(52,PSIFN,9999999.24,"I")
+5 IF 'ATF
SET RES="I"
+6 IF '$TEST
Begin DoDot:1
+7 SET PRT=$$CKRXACT^APSPFNC6(PSIFN,"B","PR")
+8 IF PMY
Begin DoDot:2
+9 ; if pharmacy and either transmitted or failed to transmit and no print then return E
+10 ; else
+11 ;S RES="E"
IF $$CKRXACT^APSPFNC6(PSIFN,"X","T")!($$CKRXACT^APSPFNC6(PSIFN,"X","F"))!($$CKRXACT^APSPFNC6(PSIFN,"X","U"))&('PRT)
Begin DoDot:3
+12 ;I 'PRT D
+13 SET LACT=$$LASTACT^APSPFNC6(PSIFN,"X")
+14 SET RES=$SELECT(LACT="F":"F",LACT="T":"E",LACT="X":"E",LACT="U":"S",1:"")
End DoDot:3
+15 IF '$TEST
SET RES=$SELECT(PRT:"P",1:"Q")
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 SET RES=$SELECT(PRT:"P",1:"Q")
End DoDot:2
End DoDot:1
+18 QUIT RES
+19 ; Return external pharmacy information
EPHARM(PSIFN) ;EP-
+1 QUIT $$GET1^DIQ(52,PSIFN,9999999.24,"I")_";"_$$GET1^DIQ(52,PSIFN,9999999.24)
+2 ; Get pharmacy IFN from order IFN
GETPSIFN(ORIFN) ;
+1 NEW PKG,PSIFN
+2 SET PKG=+$PIECE($GET(^OR(100,+ORIFN,0)),U,14)
SET PSIFN=$PIECE($GET(^(4)),U)
+3 QUIT $SELECT('PSIFN!(PKG'=$ORDER(^DIC(9.4,"C","PSO",0))):"",1:PSIFN)
+4 ; RPC: BEHORXFN SETCMF
+5 ; Set chronic med flag for one or more prescriptions
+6 ; DFN = Patient IEN
+7 ; RXS = Order ID or list of order IDs
+8 ; CMF = New value for chronic med flag (0 or 1)
+9 ; DATA returned as list in format:
+10 ; OrderID^Error Text (null if no error)
SETCMF(DATA,DFN,RXS,CMF) ;EP
+1 NEW LP,FDA,FDX,ERR,PLC,ORIFN,IDS,X
+2 IF $LENGTH($GET(RXS))
SET RXS(-1)=RXS
+3 SET LP=""
SET PLC=0
+4 FOR
SET LP=$ORDER(RXS(LP))
IF '$LENGTH(LP)
QUIT
DO SETCMF1(RXS(LP))
+5 IF $DATA(FDA)
DO UPDATE^DIE("E","FDA",,"ERR")
+6 FOR
SET LP=$ORDER(ERR("DIERR",LP))
IF 'LP
QUIT
Begin DoDot:1
+7 SET ORIFN=FDX($GET(ERR("DIERR",LP,"PARAM","FILE"),100.045),ERR("DIERR",LP,"PARAM","IENS"))
+8 DO ADDERR(ERR("DIERR",LP,"TEXT",1))
End DoDot:1
+9 QUIT
+10 ; Set CMF flag in FDA array for specified order and associated script
SETCMF1(ORIFN) ;
+1 NEW PSIFN,OK
+2 SET IDS(ORIFN)=LP
SET DATA(LP)=ORIFN
+3 IF $PIECE($GET(^OR(100,+ORIFN,0)),U,2)'=(DFN_";DPT(")
Begin DoDot:1
+4 DO ADDERR("Prescription does not belong to current patient.")
End DoDot:1
QUIT
+5 SET PSIFN=$$GETPSIFN(ORIFN)
+6 ; Set CMF on script
IF PSIFN=+PSIFN
DO ADDFDA(52,PSIFN_",",9999999.02)
+7 ; Find CMF prompt on order
SET OK=+$ORDER(^OR(100,+ORIFN,4.5,"ID","CMF",0))
+8 ; If prompt found, change response
IF OK
Begin DoDot:1
+9 DO ADDFDA(100.045,OK_","_+ORIFN_",",1)
End DoDot:1
+10 ; Else add prompt and set response
IF '$TEST
Begin DoDot:1
+11 NEW X,DLG,PMT,CMI,CMN,IENS
+12 SET DLG=$PIECE($GET(^OR(100,+ORIFN,0)),U,5)
+13 IF DLG'[";ORD(101.41,"
QUIT
+14 SET DLG=+DLG
SET CMI=+$ORDER(^ORD(101.41,"B","OR GTX CMF",0))
+15 SET CMN=$ORDER(^ORD(101.41,DLG,10,"D",CMI,0))
+16 IF 'CMN
QUIT
+17 SET PLC=PLC+1
SET IENS="+"_PLC_","_+ORIFN_","
SET OK=1
+18 SET FDA(100.045,IENS,.01)=CMN
+19 SET FDA(100.045,IENS,.02)="`"_CMI
+20 SET FDA(100.045,IENS,.03)=1
+21 SET FDA(100.045,IENS,.04)="CMF"
+22 DO ADDFDA(100.045,IENS,1)
End DoDot:1
+23 IF 'OK
DO ADDERR("Cannot set chronic med status on this order.")
+24 QUIT
+25 ; Add to FDA array
ADDFDA(FN,IENS,FLD) ;
+1 SET FDA(FN,IENS,FLD)=$SELECT(CMF:"Y",1:"N")
SET FDX(FN,IENS)=ORIFN
+2 QUIT
+3 ; Add error text
ADDERR(TXT) ;
+1 SET DATA(IDS(ORIFN))=ORIFN_U_TXT
+2 QUIT
+3 ; Get list of active/pending med orders for order checking
OCALL(DATA,DFN) ;EP
+1 NEW CNT,OBJ,ORIEN,ORLOG,X,ST
+2 SET OBJ=DFN_";DPT("
SET (CNT,ORLOG)=0
SET DATA=$$TMPGBL^CIAVMRPC
+3 FOR
SET ORLOG=$ORDER(^OR(100,"AC",OBJ,ORLOG))
IF 'ORLOG
QUIT
Begin DoDot:1
+4 SET ORIEN=0
+5 FOR
SET ORIEN=$ORDER(^OR(100,"AC",OBJ,ORLOG,ORIEN))
IF 'ORIEN
QUIT
Begin DoDot:2
+6 IF $DATA(@DATA@(0,ORIEN))
QUIT
+7 SET @DATA@(0,ORIEN)=""
+8 SET X=$GET(^OR(100,ORIEN,0))
SET ST=$PIECE($GET(^(3)),U,3)
+9 IF ST'=5
IF ST'=6
IF ST'=11
QUIT
+10 IF $PIECE(X,U,2)'=OBJ
QUIT
+11 SET PKG=$$GET1^DIQ(9.4,$PIECE(X,U,14),1)
+12 IF $EXTRACT(PKG,1,2)'="PS"
QUIT
+13 SET CNT=CNT+1
SET @DATA@(CNT)=ORIEN
End DoDot:2
End DoDot:1
+14 KILL @DATA@(0)
+15 QUIT
+16 ; Cleanup PCC Link in NVA node
CLNNVA ;EP -
+1 IF $$PATCH^XPDUTL("APSP*7.0*1009")
QUIT
+2 NEW DFN,IEN,FDA,NVAERR
+3 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"APCC","+1",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PS(55,"APCC","+1",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 SET FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
End DoDot:2
End DoDot:1
+6 IF $DATA(FDA)
DO UPDATE^DIE("","FDA",,"NVAERR")
+7 QUIT
+8 ; Returns boolean flag indicating if order is Order For Signature
ORDFSIG(ORIFN) ;EP-
+1 NEW ORD
+2 SET ORD=$GET(^OR(100,ORIFN,4))
+3 QUIT (ORD?.N1"S")&($PIECE($GET(^OR(100,ORIFN,3)),U,3)=5)
+4 ; Returns string containing vital measurement
+5 ; Date/time^Imperial value^Metric value
VITALFMT(DATA,DFN,TYP) ;EP-
+1 SET DATA=""
+2 IF '$GET(DFN)
QUIT
+3 IF '$LENGTH($GET(TYP))
QUIT
+4 SET DATA=$$VITALF^APSPFUNC(DFN,TYP)
+5 SET DATA=$PIECE(DATA,U)_U_$PIECE(DATA,U,8,9)
+6 QUIT
