Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPFNC1

APSPFNC1.m

Go to the documentation of this file. 
  1. 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
  1.  ;=================================================================
  1.  ; RPC: APSPFNC GETRXS
  1.  ; Fetch list of current prescriptions
  1.  ; DFN = Patient IEN
  1.  ; DAYS= # days to include in search (default = 365)
  1.  ; DATA returned as a list in the format for each script:
  1.  ;   ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID^Status^LastFill^Chronic^Issued^Rx #^Provider^Status Reason
  1.  ;   <"\" or " "><Instruction Text>  where "\" indicates a new line
  1.  ; Retrieve active inpatient & outpatient meds
  1. GETRXS(DATA,DFN,DAYS) ;
  1.  N ITMP,ILST,DAT
  1.  K ^TMP("PS",$J)
  1.  S:$G(DAYS)<1 DAYS=365
  1.  D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
  1.  S ILST=0,ITMP=""
  1.  F  S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP  D
  1.  .N INSTRUCT,COMMENTS,FIELDS,TYPE,CMF,RXN,PRV,RSN,J
  1.  .S (INSTRUCT,COMMENTS,CMF,RXN,RSN)="",FIELDS=^TMP("PS",$J,ITMP,0),PRV=$P($G(^("P",0)),U,2)
  1.  .                                                                     ;S:$D(^OR(100,+$P(FIELDS,U,8),8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,ITMP,0),U,2)
  1.  .S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
  1.  .S:$O(^TMP("PS",$J,ITMP,"A",0))>0 TYPE="IV"
  1.  .S:$O(^TMP("PS",$J,ITMP,"B",0))>0 TYPE="IV"
  1.  .I TYPE="UD" D
  1.  ..D UDINST(.INSTRUCT,ITMP)
  1.  ..D SETMULT(.COMMENTS,ITMP,"SIO")
  1.  .E  I TYPE="OP" D
  1.  ..D OPINST(.INSTRUCT,ITMP)
  1.  ..S CMF=$$GETCMF1($P(FIELDS,U,8))
  1.  ..S J=$P($P(FIELDS,U),";")
  1.  ..I J["R" D
  1.  ...S RXN=$P($G(^PSRX(+J,0)),U),J=$G(^(2))
  1.  ...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))
  1.  .E  I TYPE="IV" D
  1.  ..D IVINST(.INSTRUCT,ITMP)
  1.  ..D SETMULT(.COMMENTS,ITMP,"SIO")
  1.  .S:$D(COMMENTS(1)) COMMENTS(1)="\"_COMMENTS(1)
  1.  .S:$P(FIELDS,U,9)="HOLD" RSN=$$HLDRSN($P(FIELDS,U,8))
  1.  .S @DATA@($$NXT)="~"_TYPE_U_$P(FIELDS,U,1,10)_U_CMF_U_$P(FIELDS,U,15)_U_RXN_U_PRV_U_RSN
  1.  .S J=0
  1.  .F  S J=+$O(INSTRUCT(J)) Q:'J  S @DATA@($$NXT)=INSTRUCT(J)
  1.  .F  S J=+$O(COMMENTS(J)) Q:'J  S @DATA@($$NXT)="t"_COMMENTS(J)
  1.  K ^TMP("PS",$J)
  1.  Q
  1.  ; Increment ILST
  1. NXT() S ILST=ILST+1
  1.  Q ILST
  1.  ; Return hold reason
  1. HLDRSN(ORIFN) ;
  1.  N RSN,PSIFN,X
  1.  S X=$O(^OR(100,+ORIFN,8,"C","HD",""),-1)
  1.  S:$O(^OR(100,+ORIFN,8,"C","RL",X)) X=""
  1.  S RSN=$S('X:"",1:$G(^OR(100,+ORIFN,8,X,1)))
  1.  S PSIFN=$$GETPSIFN(ORIFN)
  1.  I PSIFN=+PSIFN D
  1.  .S X=$$GET1^DIQ(52,PSIFN,99.1)
  1.  .S:'$L(X) X=$$GET1^DIQ(52,PSIFN,99),X=$S($E(X,1,5)="OTHER":"",1:X)
  1.  .S:$L(X) RSN=X
  1.  Q "Hold Reason:  "_$S($L(RSN):RSN,1:"Not specified")
  1.  ; Return chronic med flag from order IFN
  1. GETCMF1(ORIFN) ;
  1.  N PSIFN
  1.  S PSIFN=$$GETPSIFN(ORIFN)
  1.  Q:PSIFN=+PSIFN $$GET1^DIQ(52,PSIFN,9999999.02)["Y"
  1.  Q $$VALUE^ORCSAVE2(+ORIFN,"CMF")["Y"
  1.  ; Get pharmacy IFN from order IFN
  1. GETPSIFN(ORIFN) ;
  1.  N PKG,PSIFN
  1.  S PKG=+$P($G(^OR(100,+ORIFN,0)),U,14),PSIFN=$P($G(^(4)),U)
  1.  Q $S('PSIFN!(PKG'=$O(^DIC(9.4,"C","PSO",0))):"",1:PSIFN)
  1.  ; RPC: APSPFNC SETCMF
  1.  ; Set chronic med flag for one or more prescriptions
  1.  ; DFN = Patient IEN
  1.  ; RXS = Order ID or list of order IDs
  1.  ; CMF = New value for chronic med flag (0 or 1)
  1.  ; DATA returned as list of errors in format:
  1.  ;   OrderID^Error Text
  1. SETCMF(DATA,DFN,RXS,CMF) ;EP
  1.  N LP,FDA,FDX,ERR,PLC,ORIFN,X
  1.  S:$L($G(RXS)) RXS(-1)=RXS
  1.  S LP="",PLC=0
  1.  F  S LP=$O(RXS(LP)) Q:'$L(LP)  D SETCMF1(RXS(LP))
  1.  D:$D(FDA) UPDATE^DIE("E","FDA",,"ERR")
  1.  F  S LP=$O(ERR("DIERR",LP)) Q:'LP  D
  1.  .S ORIFN=FDX($G(ERR("DIERR",LP,"PARAM","FILE"),100.045),ERR("DIERR",LP,"PARAM","IENS"))
  1.  .D ADDERR(ERR("DIERR",LP,"TEXT",1))
  1.  Q
  1.  ; Set CMF flag in FDA array for specified order and associated script
  1. SETCMF1(ORIFN) ;
  1.  N PSIFN,OK
  1.  I $P($G(^OR(100,+ORIFN,0)),U,2)'=(DFN_";DPT(") D  Q
  1.  .D ADDERR("Prescription does not belong to current patient.")
  1.  S PSIFN=$$GETPSIFN(ORIFN)
  1.  I 'PSIFN D ADDERR("Not a pharmacy order.") Q
  1.  D:PSIFN=+PSIFN ADDFDA(52,PSIFN_",",9999999.02)                        ; Set CMF on script
  1.  S OK=+$O(^OR(100,+ORIFN,4.5,"ID","CMF",0))                            ; Find CMF prompt on order
  1.  I OK D                                                                ; If prompt found, change response
  1.  .D ADDFDA(100.045,OK_","_+ORIFN_",",1)
  1.  E  D                                                                  ; Else add prompt and set response
  1.  .N X,DLG,PMT,CMI,CMN,IENS
  1.  .S DLG=$P($G(^OR(100,+ORIFN,0)),U,5)
  1.  .Q:DLG'[";ORD(101.41,"
  1.  .S DLG=+DLG,CMI=+$O(^ORD(101.41,"B","OR GTX CMF",0))
  1.  .S CMN=$O(^ORD(101.41,DLG,10,"D",CMI,0))
  1.  .Q:'CMN
  1.  .S PLC=PLC+1,IENS="+"_PLC_","_+ORIFN_",",OK=1
  1.  .S FDA(100.045,IENS,.01)=CMN
  1.  .S FDA(100.045,IENS,.02)="`"_CMI
  1.  .S FDA(100.045,IENS,.03)=1
  1.  .S FDA(100.045,IENS,.04)="CMF"
  1.  .D ADDFDA(100.045,IENS,1)
  1.  D:'OK ADDERR("Cannot set chronic med status on this order.")
  1.  Q
  1.  ; Add to FDA array
  1. ADDFDA(FN,IENS,FLD) ;
  1.  S FDA(FN,IENS,FLD)=$S(CMF:"Y",1:"N"),FDX(FN,IENS)=ORIFN
  1.  Q
  1.  ; Add error text
  1. ADDERR(TXT) ;
  1.  S DATA(1+$O(DATA(""),-1))=ORIFN_U_TXT
  1.  Q
  1.  ; Assembles instructions for a unit dose order
  1. UDINST(Y,INDEX) ;
  1.  N I,X
  1.  S X=^TMP("PS",$J,INDEX,0)
  1.  S Y(1)=" "_$P(X,U,2),Y=1
  1.  S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
  1.  I $L(X) S Y=2,Y(2)=X
  1.  E  S Y=1 D SETMULT(.Y,INDEX,"SIG")
  1.  S Y(2)="\Give: "_$G(Y(2)),Y=$G(Y,2)
  1.  D SETMULT(.Y,INDEX,"MDR"),SETMULT(.Y,INDEX,"SCH")
  1.  F I=3:1:Y S Y(I)=" "_Y(I)
  1.  Q
  1.  ; Assembles instructions for an outpatient prescription
  1. OPINST(Y,INDEX) ;
  1.  N I,X
  1.  S X=^TMP("PS",$J,INDEX,0)
  1.  S Y(1)=" "_$P(X,U,2),Y=1
  1.  S:$L($P(X,U,12)) Y(1)=Y(1)_"  Qty: "_$P(X,U,12)
  1.  S:$L($P(X,U,11)) Y(1)=Y(1)_" for "_$P(X,U,11)_" days"
  1.  D SETMULT(.Y,INDEX,"SIG")
  1.  I Y=1 D
  1.  .D SETMULT(.Y,INDEX,"SIO")
  1.  .D SETMULT(.Y,INDEX,"MDR")
  1.  .D SETMULT(.Y,INDEX,"SCH")
  1.  S Y(2)="\ Sig: "_$G(Y(2))
  1.  F I=3:1:Y S Y(I)=" "_Y(I)
  1.  Q
  1.  ; Assembles instructions for an IV order
  1. IVINST(Y,INDEX) ;
  1.  N SOLN1,I
  1.  S Y=0
  1.  D SETMULT(.Y,INDEX,"A")
  1.  S SOLN1=Y+1
  1.  D SETMULT(.Y,INDEX,"B")
  1.  I $D(Y(SOLN1)),$L($P(FIELDS,U,2)) S Y(SOLN1)="in "_Y(SOLN1)
  1.  S SOLN1=Y+1
  1.  D SETMULT(.Y,INDEX,"SCH")
  1.  S:$D(Y(SOLN1)) Y(SOLN1)=" "_Y(SOLN1)
  1.  F I=1:1:Y S Y(I)="\"_$TR(Y(I),U," ")
  1.  S:$D(Y(1)) Y(1)=" "_$E(Y(1),2,999)
  1.  S Y(Y)=Y(Y)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
  1.  Q
  1.  ; Appends the multiple at the subscript to Y
  1. SETMULT(Y,INDEX,SUB) ;
  1.  N I
  1.  S I=0
  1.  F  S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I  D
  1.  .S Y=Y+1,Y(Y)=^TMP("PS",$J,INDEX,SUB,I,0)
  1.  Q
  1.  ; Return Activity Log items for given prescription
  1. ACTLOG(DATA,RX) ;EP
  1.  N AIEN,A0,CNT
  1.  S CNT=0
  1.  S AIEN=0 F  S AIEN=$O(^PSRX(RX,"A",AIEN)) Q:'AIEN  D
  1.  .S A0=^PSRX(RX,"A",AIEN,0)
  1.  .S $P(A0,U,6)=$G(^PSRX(RX,"A",AIEN,9999999))
  1.  .S CNT=CNT+1
  1.  .S DATA(CNT)=AIEN_U_A0
  1.  Q
  1.  ; Return RXNORM value for associated NDC
  1.  ; Patch 1017 changed to use Apelon lookup for RxNorm code
  1. RXNORM(NDC,FLG) ;EP-
  1.  N RXNORM,IN,ZDATA
  1.  S RXNORM="",FLG=$G(FLG)
  1.  S NDC=$TR($G(NDC),"-","")
  1.  Q:NDC="" ""
  1.  S IN=NDC_"^N"
  1.  S ZDATA=$$DI2RX^BSTSAPI(IN)
  1.  S RXNORM=$P(ZDATA,U,1)
  1.  I FLG S RXNORM=RXNORM_U_$P(ZDATA,U,5)
  1.  Q RXNORM
  1.  ;Patch 1017 Return RXNORM value for indicated drug
  1.  ;Check the drug file or else lookup in Apelon tool
  1. RXNORDRG(DRUG) ;EP -
  1.  N RXNORM
  1.  S RXNORM=""
  1.  ;S RXNORM=$$GET1^DIQ(50,DRUG,9999999.27)
  1.  I RXNORM="" S RXNORM=$$SQUERY^APSPRCUI(DRUG,1)
  1.  Q RXNORM
  1. GETNDC(DRUG,PICKUP) ;EP -
  1.  N NDC
  1.  Q:PICKUP="" ""
  1.  S NDC=$S(PICKUP="E":$$NAT(DRUG),PICKUP="P":$$NAT(DRUG),1:$$LOCAL(DRUG))
  1.  Q NDC
  1. LOCAL(DRG) ;Use drug NDC code
  1.  N NDC
  1.  S NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31)) I NDC'="" Q NDC
  1.  ; - National Drug File NDC
  1.  S NDC=$$NDC^APSPES4(DRG) S NDC=$$NDCFMT^PSSNDCUT(NDC)
  1.  Q NDC
  1. NAT(DRG) ;Use national NDC code
  1.  N NDC,NDF
  1.  ; - National Drug File NDC
  1.  S NDC=$$NDC^APSPES4(DRG) S NDC=$$NDCFMT^PSSNDCUT(NDC) I NDC'="" Q NDC
  1.  S NDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31))
  1.  Q NDC
  1.  ; Return Dispense SIG in RXD segment of APSP REFILL REQUEST entry
  1. SSDSIG(REFREQ) ;EP-
  1.  N HLECH,DEL,I
  1.  S HLECH="^~\&"
  1.  F I=1:1:4 D
  1.  .S HLECH(I)=$E(HLECH,I)
  1.  S DEL="|"
  1.  S HLMSG=$$GHLDAT^APSPESG1(REFREQ)
  1.  Q:'$L(HLMSG) ""
  1.  Q $P($P($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,10),HLECH(1),1)
  1.  ; Return Notes to Pharmacist in RXD segment of APSP REFILL REQUEST entry
  1. SSDNTP(REFREQ) ;EP-
  1.  N HLECH,DEL,I
  1.  S HLECH="^~\&"
  1.  F I=1:1:4 D
  1.  .S HLECH(I)=$E(HLECH,I)
  1.  S DEL="|"
  1.  S HLMSG=$$GHLDAT^APSPESG1(REFREQ)
  1.  Q:'$L(HLMSG) ""
  1.  Q $P($P($$GETSEG^APSPESG(.HLDATA,"RXD"),DEL,16),HLECH(1),2)