APSPFNC1 ;IHS/CIA/DKM/PLS - Supporting calls for EHR and Pharmacy;12-Mar-2014 16:06;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1006,1016,1017,1018**;Sep 23, 2004;Build 21
;=================================================================
; RPC: APSPFNC 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^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID^Status^LastFill^Chronic^Issued^Rx #^Provider^Status Reason
; <"\" or " "><Instruction Text> where "\" indicates a new line
; Retrieve active inpatient & outpatient meds
GETRXS(DATA,DFN,DAYS) ;
N ITMP,ILST,DAT
K ^TMP("PS",$J)
S:$G(DAYS)<1 DAYS=365
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
S ILST=0,ITMP=""
F S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP D
.N INSTRUCT,COMMENTS,FIELDS,TYPE,CMF,RXN,PRV,RSN,J
.S (INSTRUCT,COMMENTS,CMF,RXN,RSN)="",FIELDS=^TMP("PS",$J,ITMP,0),PRV=$P($G(^("P",0)),U,2)
. ;S:$D(^OR(100,+$P(FIELDS,U,8),8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,ITMP,0),U,2)
.S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
.S:$O(^TMP("PS",$J,ITMP,"A",0))>0 TYPE="IV"
.S:$O(^TMP("PS",$J,ITMP,"B",0))>0 TYPE="IV"
.I TYPE="UD" D
..D UDINST(.INSTRUCT,ITMP)
..D SETMULT(.COMMENTS,ITMP,"SIO")
.E I TYPE="OP" D
..D OPINST(.INSTRUCT,ITMP)
..S CMF=$$GETCMF1($P(FIELDS,U,8))
..S J=$P($P(FIELDS,U),";")
..I J["R" D
...S RXN=$P($G(^PSRX(+J,0)),U),J=$G(^(2))
...I '$P(J,U,13),$P(J,U,15) S $P(FIELDS,U,9,10)="Not Picked Up^",RSN="Returned to stock on "_$$FMTE^XLFDT($P(J,U,15))
.E I TYPE="IV" D
..D IVINST(.INSTRUCT,ITMP)
..D SETMULT(.COMMENTS,ITMP,"SIO")
.S:$D(COMMENTS(1)) COMMENTS(1)="\"_COMMENTS(1)
.S:$P(FIELDS,U,9)="HOLD" RSN=$$HLDRSN($P(FIELDS,U,8))
.S @DATA@($$NXT)="~"_TYPE_U_$P(FIELDS,U,1,10)_U_CMF_U_$P(FIELDS,U,15)_U_RXN_U_PRV_U_RSN
.S J=0
.F S J=+$O(INSTRUCT(J)) Q:'J S @DATA@($$NXT)=INSTRUCT(J)
.F S J=+$O(COMMENTS(J)) Q:'J S @DATA@($$NXT)="t"_COMMENTS(J)
K ^TMP("PS",$J)
Q
; Increment ILST
NXT() S ILST=ILST+1
Q ILST
; 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) ;
N PSIFN
S PSIFN=$$GETPSIFN(ORIFN)
Q:PSIFN=+PSIFN $$GET1^DIQ(52,PSIFN,9999999.02)["Y"
Q $$VALUE^ORCSAVE2(+ORIFN,"CMF")["Y"
; 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: APSPFNC 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 of errors in format:
; OrderID^Error Text
SETCMF(DATA,DFN,RXS,CMF) ;EP
N LP,FDA,FDX,ERR,PLC,ORIFN,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
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)
I 'PSIFN D ADDERR("Not a pharmacy order.") Q
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(1+$O(DATA(""),-1))=ORIFN_U_TXT
Q
; Assembles instructions for a unit dose order
UDINST(Y,INDEX) ;
N I,X
S X=^TMP("PS",$J,INDEX,0)
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,INDEX,"SIG")
S Y(2)="\Give: "_$G(Y(2)),Y=$G(Y,2)
D SETMULT(.Y,INDEX,"MDR"),SETMULT(.Y,INDEX,"SCH")
F I=3:1:Y S Y(I)=" "_Y(I)
Q
; Assembles instructions for an outpatient prescription
OPINST(Y,INDEX) ;
N I,X
S X=^TMP("PS",$J,INDEX,0)
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,INDEX,"SIG")
I Y=1 D
.D SETMULT(.Y,INDEX,"SIO")
.D SETMULT(.Y,INDEX,"MDR")
.D SETMULT(.Y,INDEX,"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,INDEX) ;
N SOLN1,I
S Y=0
D SETMULT(.Y,INDEX,"A")
S SOLN1=Y+1
D SETMULT(.Y,INDEX,"B")
I $D(Y(SOLN1)),$L($P(FIELDS,U,2)) S Y(SOLN1)="in "_Y(SOLN1)
S SOLN1=Y+1
D SETMULT(.Y,INDEX,"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(^TMP("PS",$J,INDEX,0),U,3)
Q
; Appends the multiple at the subscript to Y
SETMULT(Y,INDEX,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 Activity Log items for given prescription
ACTLOG(DATA,RX) ;EP
N AIEN,A0,CNT
S CNT=0
S AIEN=0 F S AIEN=$O(^PSRX(RX,"A",AIEN)) Q:'AIEN D
.S A0=^PSRX(RX,"A",AIEN,0)
.S $P(A0,U,6)=$G(^PSRX(RX,"A",AIEN,9999999))
.S CNT=CNT+1
.S DATA(CNT)=AIEN_U_A0
Q
; Return RXNORM value for associated NDC
; Patch 1017 changed to use Apelon lookup for RxNorm code
RXNORM(NDC,FLG) ;EP-
N RXNORM,IN,ZDATA
S RXNORM="",FLG=$G(FLG)
S NDC=$TR($G(NDC),"-","")
Q:NDC="" ""
S IN=NDC_"^N"
S ZDATA=$$DI2RX^BSTSAPI(IN)
S RXNORM=$P(ZDATA,U,1)
I FLG S RXNORM=RXNORM_U_$P(ZDATA,U,5)
Q RXNORM
;Patch 1017 Return RXNORM value for indicated drug
;Check the drug file or else lookup in Apelon tool
RXNORDRG(DRUG) ;EP -
N RXNORM
S RXNORM=""
;S RXNORM=$$GET1^DIQ(50,DRUG,9999999.27)
I RXNORM="" S RXNORM=$$SQUERY^APSPRCUI(DRUG,1)
Q RXNORM
GETNDC(DRUG,PICKUP) ;EP -
N NDC
Q:PICKUP="" ""
S NDC=$S(PICKUP="E":$$NAT(DRUG),PICKUP="P":$$NAT(DRUG),1:$$LOCAL(DRUG))
Q NDC
LOCAL(DRG) ;Use drug NDC code
N NDC
S NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31)) I NDC'="" Q NDC
; - National Drug File NDC
S NDC=$$NDC^APSPES4(DRG) S NDC=$$NDCFMT^PSSNDCUT(NDC)
Q NDC
NAT(DRG) ;Use national NDC code
N NDC,NDF
; - National Drug File NDC
S NDC=$$NDC^APSPES4(DRG) S NDC=$$NDCFMT^PSSNDCUT(NDC) I NDC'="" Q NDC
S NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31))
Q NDC
; Return Dispense SIG in RXD segment of APSP REFILL REQUEST entry
SSDSIG(REFREQ) ;EP-
N HLECH,DEL,I
S HLECH="^~\&"
F I=1:1:4 D
.S HLECH(I)=$E(HLECH,I)
S DEL="|"
S HLMSG=$$GHLDAT^APSPESG1(REFREQ)
Q:'$L(HLMSG) ""
Q $P($P($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,10),HLECH(1),1)
; Return Notes to Pharmacist in RXD segment of APSP REFILL REQUEST entry
SSDNTP(REFREQ) ;EP-
N HLECH,DEL,I
S HLECH="^~\&"
F I=1:1:4 D
.S HLECH(I)=$E(HLECH,I)
S DEL="|"
S HLMSG=$$GHLDAT^APSPESG1(REFREQ)
Q:'$L(HLMSG) ""
Q $P($P($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,16),HLECH(1),2)
APSPFNC1 ;IHS/CIA/DKM/PLS - Supporting calls for EHR and Pharmacy;12-Mar-2014 16:06;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1004,1006,1016,1017,1018**;Sep 23, 2004;Build 21
+2 ;=================================================================
+3 ; RPC: APSPFNC GETRXS
+4 ; Fetch list of current prescriptions
+5 ; DFN = Patient IEN
+6 ; DAYS= # days to include in search (default = 365)
+7 ; DATA returned as a list in the format for each script:
+8 ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID^Status^LastFill^Chronic^Issued^Rx #^Provider^Status Reason
+9 ; <"\" or " "><Instruction Text> where "\" indicates a new line
+10 ; Retrieve active inpatient & outpatient meds
GETRXS(DATA,DFN,DAYS) ;
+1 NEW ITMP,ILST,DAT
+2 KILL ^TMP("PS",$JOB)
+3 IF $GET(DAYS)<1
SET DAYS=365
+4 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
+5 SET ILST=0
SET ITMP=""
+6 FOR
SET ITMP=$ORDER(^TMP("PS",$JOB,ITMP),-1)
IF 'ITMP
QUIT
Begin DoDot:1
+7 NEW INSTRUCT,COMMENTS,FIELDS,TYPE,CMF,RXN,PRV,RSN,J
+8 SET (INSTRUCT,COMMENTS,CMF,RXN,RSN)=""
SET FIELDS=^TMP("PS",$JOB,ITMP,0)
SET PRV=$PIECE($GET(^("P",0)),U,2)
+9 ;S:$D(^OR(100,+$P(FIELDS,U,8),8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,ITMP,0),U,2)
+10 SET TYPE=$SELECT($PIECE($PIECE(FIELDS,U),";",2)="O":"OP",1:"UD")
+11 IF $ORDER(^TMP("PS",$JOB,ITMP,"A",0))>0
SET TYPE="IV"
+12 IF $ORDER(^TMP("PS",$JOB,ITMP,"B",0))>0
SET TYPE="IV"
+13 IF TYPE="UD"
Begin DoDot:2
+14 DO UDINST(.INSTRUCT,ITMP)
+15 DO SETMULT(.COMMENTS,ITMP,"SIO")
End DoDot:2
+16 IF '$TEST
IF TYPE="OP"
Begin DoDot:2
+17 DO OPINST(.INSTRUCT,ITMP)
+18 SET CMF=$$GETCMF1($PIECE(FIELDS,U,8))
+19 SET J=$PIECE($PIECE(FIELDS,U),";")
+20 IF J["R"
Begin DoDot:3
+21 SET RXN=$PIECE($GET(^PSRX(+J,0)),U)
SET J=$GET(^(2))
+22 IF '$PIECE(J,U,13)
IF $PIECE(J,U,15)
SET $PIECE(FIELDS,U,9,10)="Not Picked Up^"
SET RSN="Returned to stock on "_$$FMTE^XLFDT($PIECE(J,U,15))
End DoDot:3
End DoDot:2
+23 IF '$TEST
IF TYPE="IV"
Begin DoDot:2
+24 DO IVINST(.INSTRUCT,ITMP)
+25 DO SETMULT(.COMMENTS,ITMP,"SIO")
End DoDot:2
+26 IF $DATA(COMMENTS(1))
SET COMMENTS(1)="\"_COMMENTS(1)
+27 IF $PIECE(FIELDS,U,9)="HOLD"
SET RSN=$$HLDRSN($PIECE(FIELDS,U,8))
+28 SET @DATA@($$NXT)="~"_TYPE_U_$P(FIELDS,U,1,10)_U_CMF_U_$PIECE(FIELDS,U,15)_U_RXN_U_PRV_U_RSN
+29 SET J=0
+30 FOR
SET J=+$ORDER(INSTRUCT(J))
IF 'J
QUIT
SET @DATA@($$NXT)=INSTRUCT(J)
+31 FOR
SET J=+$ORDER(COMMENTS(J))
IF 'J
QUIT
SET @DATA@($$NXT)="t"_COMMENTS(J)
End DoDot:1
+32 KILL ^TMP("PS",$JOB)
+33 QUIT
+34 ; Increment ILST
NXT() SET ILST=ILST+1
+1 QUIT ILST
+2 ; 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) ;
+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 ; 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: APSPFNC 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 of errors in format:
+10 ; OrderID^Error Text
SETCMF(DATA,DFN,RXS,CMF) ;EP
+1 NEW LP,FDA,FDX,ERR,PLC,ORIFN,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 IF $PIECE($GET(^OR(100,+ORIFN,0)),U,2)'=(DFN_";DPT(")
Begin DoDot:1
+3 DO ADDERR("Prescription does not belong to current patient.")
End DoDot:1
QUIT
+4 SET PSIFN=$$GETPSIFN(ORIFN)
+5 IF 'PSIFN
DO ADDERR("Not a pharmacy order.")
QUIT
+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(1+$ORDER(DATA(""),-1))=ORIFN_U_TXT
+2 QUIT
+3 ; Assembles instructions for a unit dose order
UDINST(Y,INDEX) ;
+1 NEW I,X
+2 SET X=^TMP("PS",$JOB,INDEX,0)
+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,INDEX,"SIG")
+7 SET Y(2)="\Give: "_$GET(Y(2))
SET Y=$GET(Y,2)
+8 DO SETMULT(.Y,INDEX,"MDR")
DO SETMULT(.Y,INDEX,"SCH")
+9 FOR I=3:1:Y
SET Y(I)=" "_Y(I)
+10 QUIT
+11 ; Assembles instructions for an outpatient prescription
OPINST(Y,INDEX) ;
+1 NEW I,X
+2 SET X=^TMP("PS",$JOB,INDEX,0)
+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,INDEX,"SIG")
+7 IF Y=1
Begin DoDot:1
+8 DO SETMULT(.Y,INDEX,"SIO")
+9 DO SETMULT(.Y,INDEX,"MDR")
+10 DO SETMULT(.Y,INDEX,"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,INDEX) ;
+1 NEW SOLN1,I
+2 SET Y=0
+3 DO SETMULT(.Y,INDEX,"A")
+4 SET SOLN1=Y+1
+5 DO SETMULT(.Y,INDEX,"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,INDEX,"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(^TMP("PS",$JOB,INDEX,0),U,3)
+13 QUIT
+14 ; Appends the multiple at the subscript to Y
SETMULT(Y,INDEX,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 Activity Log items for given prescription
ACTLOG(DATA,RX) ;EP
+1 NEW AIEN,A0,CNT
+2 SET CNT=0
+3 SET AIEN=0
FOR
SET AIEN=$ORDER(^PSRX(RX,"A",AIEN))
IF 'AIEN
QUIT
Begin DoDot:1
+4 SET A0=^PSRX(RX,"A",AIEN,0)
+5 SET $PIECE(A0,U,6)=$GET(^PSRX(RX,"A",AIEN,9999999))
+6 SET CNT=CNT+1
+7 SET DATA(CNT)=AIEN_U_A0
End DoDot:1
+8 QUIT
+9 ; Return RXNORM value for associated NDC
+10 ; Patch 1017 changed to use Apelon lookup for RxNorm code
RXNORM(NDC,FLG) ;EP-
+1 NEW RXNORM,IN,ZDATA
+2 SET RXNORM=""
SET FLG=$GET(FLG)
+3 SET NDC=$TRANSLATE($GET(NDC),"-","")
+4 IF NDC=""
QUIT ""
+5 SET IN=NDC_"^N"
+6 SET ZDATA=$$DI2RX^BSTSAPI(IN)
+7 SET RXNORM=$PIECE(ZDATA,U,1)
+8 IF FLG
SET RXNORM=RXNORM_U_$PIECE(ZDATA,U,5)
+9 QUIT RXNORM
+10 ;Patch 1017 Return RXNORM value for indicated drug
+11 ;Check the drug file or else lookup in Apelon tool
RXNORDRG(DRUG) ;EP -
+1 NEW RXNORM
+2 SET RXNORM=""
+3 ;S RXNORM=$$GET1^DIQ(50,DRUG,9999999.27)
+4 IF RXNORM=""
SET RXNORM=$$SQUERY^APSPRCUI(DRUG,1)
+5 QUIT RXNORM
GETNDC(DRUG,PICKUP) ;EP -
+1 NEW NDC
+2 IF PICKUP=""
QUIT ""
+3 SET NDC=$SELECT(PICKUP="E":$$NAT(DRUG),PICKUP="P":$$NAT(DRUG),1:$$LOCAL(DRUG))
+4 QUIT NDC
LOCAL(DRG) ;Use drug NDC code
+1 NEW NDC
+2 SET NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31))
IF NDC'=""
QUIT NDC
+3 ; - National Drug File NDC
+4 SET NDC=$$NDC^APSPES4(DRG)
SET NDC=$$NDCFMT^PSSNDCUT(NDC)
+5 QUIT NDC
NAT(DRG) ;Use national NDC code
+1 NEW NDC,NDF
+2 ; - National Drug File NDC
+3 SET NDC=$$NDC^APSPES4(DRG)
SET NDC=$$NDCFMT^PSSNDCUT(NDC)
IF NDC'=""
QUIT NDC
+4 SET NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31))
+5 QUIT NDC
+6 ; Return Dispense SIG in RXD segment of APSP REFILL REQUEST entry
SSDSIG(REFREQ) ;EP-
+1 NEW HLECH,DEL,I
+2 SET HLECH="^~\&"
+3 FOR I=1:1:4
Begin DoDot:1
+4 SET HLECH(I)=$EXTRACT(HLECH,I)
End DoDot:1
+5 SET DEL="|"
+6 SET HLMSG=$$GHLDAT^APSPESG1(REFREQ)
+7 IF '$LENGTH(HLMSG)
QUIT ""
+8 QUIT $PIECE($PIECE($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,10),HLECH(1),1)
+9 ; Return Notes to Pharmacist in RXD segment of APSP REFILL REQUEST entry
SSDNTP(REFREQ) ;EP-
+1 NEW HLECH,DEL,I
+2 SET HLECH="^~\&"
+3 FOR I=1:1:4
Begin DoDot:1
+4 SET HLECH(I)=$EXTRACT(HLECH,I)
End DoDot:1
+5 SET DEL="|"
+6 SET HLMSG=$$GHLDAT^APSPESG1(REFREQ)
+7 IF '$LENGTH(HLMSG)
QUIT ""
+8 QUIT $PIECE($PIECE($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,16),HLECH(1),2)
