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

APCHPWHM.m

Go to the documentation of this file. 
  1. APCHPWHM ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;  
  1.  ;;2.0;IHS PCC SUITE;**2,5,7**;MAY 14, 2009;Build 1
  1.  ;
  1. MEDSACT ;EP - medications (active) component
  1.  S APCHACTO=1
  1.  D MEDS
  1.  K APCHACTO
  1.  Q
  1.  ;
  1. MEDS ;EP - medications component
  1.  ;get all meds in the past year +30 days
  1.  ;NEW APCHMEDS,APCHMED,X,M,I,N,D,APCHKEEP,APCHM,APCHRXN,APCHRXO,APCHRX0,APCHSREF,APCHSTAT,C,APCHN,APCHI,APCHD,APCHC
  1.  NEW X,M,D,N,C,Z,P,I,EXPDT
  1.  ;
  1.  ;use VA API from Phil
  1.  ;exclude discontinued and expired
  1.  ;store each drug by NAME, inverse date, get date filled, # of refills, rx #, sig and comments for hold
  1.  NEW APCHMED,APCHALL,LINDEX
  1.  D GETRXS  ;all outpatient, nva
  1.  D GETVMEDE
  1.  I '$G(APCHACTO) D GETEXP
  1.  D DISP
  1.  Q
  1.  ; RPC: BEHORXFN 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.  ;
  1.  ;   ~Type[1] ^ PharmID[2] ^ Drug[3] ^ InfRate[4] ^ StopDt[5] ^ RefRem[6] ^
  1.  ;    TotDose[7] ^ UnitDose[8] ^ OrderID[9] ^ Status[10] ^ LastFill[11] ^
  1.  ;    Days Supply[12] ^ Quantity[13] ^ Chronic[14] ^ Issued[15] ^
  1.  ;    Rx #[16] ^ Provider IEN~Name[17] ^ Status Reason[18] ^ DEA Handling[19] ^
  1.  ;    Pharmacy Site[20] ^ Indication ICD~Text[21] ^ DAW[22]
  1.  ;
  1.  ;   <"\" or " "><Instruction Text>  where "\" indicates a new line
  1. GETRXS ;
  1.  ;D CLNNVA
  1.  N INDEX,ILST,DAT
  1.  K ^TMP("PS",$J)
  1.  S DAYS=395
  1.  D OCL^PSOORRL(APCHSDFN,$$FMADD^XLFDT(DT,-DAYS),"")
  1.  S ILST=0,INDEX="",LINDEX=""
  1.  F  S INDEX=$O(^TMP("PS",$J,INDEX),-1) Q:'INDEX  S LINDEX=INDEX D
  1.  .N INSTRUCT,COMMENTS,FIELDS,NVSDT,TYPE,IND,CMF,RXN,PRV,REASON,DEA,IFN,DAW,J,K,X,APCHMEDS,DRUGNAME,DRUGND,L,APCHSRX,APCHSREF
  1.  .S (INSTRUCT,COMMENTS,IND,CMF,RXN,REASON,DEA,DAW)="",FIELDS=^TMP("PS",$J,INDEX,0),PRV=$TR($G(^("P",0)),U,"~")
  1.  .Q:$P(FIELDS,U,9)="DISCONTINUED"  ;not on PWH
  1.  .Q:$P(FIELDS,U,9)="EXPIRED"  ;not on pwh
  1.  .S IFN=+$P(FIELDS,U,8),X=$O(^OR(100,IFN,4.5,"ID","DRUG",0))
  1.  .S:X X=+$G(^OR(100,IFN,4.5,X,1))
  1.  .S:X DEA=$P($G(^PSDRUG(X,0)),U,3)
  1.  .;S:$D(^OR(100,IFN,8,"C","XX")) $P(^(0),U,2)="*"_$P(^TMP("PS",$J,INDEX,0),U,2)
  1.  .S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
  1.  .I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV"
  1.  .S:$O(^TMP("PS",$J,INDEX,"A",0))>0 TYPE="IV"
  1.  .S:$O(^TMP("PS",$J,INDEX,"B",0))>0 TYPE="IV"
  1.  .Q:$G(IFN)&$D(^TMP("PS",$J,"X",TYPE,IFN))  S ^(IFN)=""  ; OCL^PSOORRL can return dups
  1.  .I TYPE="OP" D
  1.  ..S (DRUGNAME,DRUGND)=$P(FIELDS,U,2)
  1.  ..Q:$D(APCHALL(DRUGNAME))
  1.  ..S APCHALL(DRUGNAME)=""
  1.  ..S:$L($P(FIELDS,U,12)) DRUGND=DRUGND_"  Qty: "_$P(FIELDS,U,12)
  1.  ..S:$L($P(FIELDS,U,11)) DRUGND=DRUGND_" for "_$P(FIELDS,U,11)_" days"
  1.  ..S APCHMED(DRUGNAME,INDEX)=DRUGND
  1.  ..D OPINST(.INSTRUCT)
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,5)=$G(INSTRUCT)
  1.  ..S J=$P($P(FIELDS,U),";")
  1.  ..I J["R" D
  1.  ...S RXN=$P($G(^PSRX(+J,0)),U)
  1.  ...S $P(APCHMED(DRUGNAME,INDEX),U,3)="Rx #: "_RXN
  1.  ...S H=$G(^PSRX(+J,2)),K=+$G(^PSRX(+J,"STA"))
  1.  ...S L=$P($G(^PSRX(+J,3)),U,1)  ;last dispensed date
  1.  ...I L="" S L=$O(^PSRX(I,1,"B",9999999),-1)
  1.  ...I L="" S L=$P($G(^PSRX(I,2)),U,2)
  1.  ...I L="" S L=$P(^PSRX(I,0),U,13)
  1.  ...S $P(APCHMED(DRUGNAME,INDEX),U,2)=L
  1.  ...S APCHSRX=+J,APCHSREF=0 D REF^APCHS7O S $P(APCHMED(DRUGNAME,INDEX),U,4)=APCHSREF
  1.  ...I K<12,'$P(J,U,13),$P(J,U,15) S $P(APCHMED(DRUGNAME,INDEX),U,7)="Not Picked Up^",REASON="Returned to stock on "_$$FMTE^XLFDT($P(J,U,15))
  1.  .E  I TYPE="NV" D
  1.  ..S DRUGNAME=$P(FIELDS,U,2)
  1.  ..Q:$D(APCHALL(DRUGNAME))
  1.  ..S APCHMED(DRUGNAME,INDEX)=DRUGNAME
  1.  ..D NVINST(.INSTRUCT)
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,5)=$G(INSTRUCT)
  1.  ..D NVREASON(.REASON,.NVSDT)
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,6)=$G(REASON)
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,2)=$G(NVSDT)
  1.  ..D SETMULT(.COMMENTS,"SIO")
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,6)=$P(APCHMED(DRUGNAME,INDEX),U,6)_$S(COMMENTS]"":"  Comments: "_COMMENTS,1:"")
  1.  .;S:$D(COMMENTS(1)) COMMENTS(1)="\"_COMMENTS(1)
  1.  .S:$P(FIELDS,U,9)="HOLD" REASON=$$HLDRSN(IFN) D
  1.  ..Q:REASON=""
  1.  ..S $P(APCHMED(DRUGNAME,INDEX),U,8)=$P(APCHMED(DRUGNAME,INDEX),U,8)_"  "_$G(REASON)
  1.  K ^TMP("PS",$J)
  1.  Q
  1.  ; Assembles instructions for an outpatient prescription
  1. OPINST(Y) ;
  1.  N I,X
  1.  D SETMULT(.Y,"SIG")
  1.  I Y="" D
  1.  .D SETMULT(.Y,"SIO")
  1.  .D SETMULT(.Y,"MDR")
  1.  .D SETMULT(.Y,"SCH")
  1.  ;S Y="Directions: "_Y
  1.  Q
  1.  ; Assembles instructions for a home med
  1. NVINST(Y) ;
  1.  N I
  1.  D SETMULT(.Y,"SIG")
  1.  I Y="" D
  1.  .D SETMULT(.Y,"SIO")
  1.  .D SETMULT(.Y,"MDR")
  1.  .D SETMULT(.Y,"SCH")
  1.  Q
  1.  ; Assembles start date and reasons for a home med
  1. NVREASON(Y,NVSDT) ;
  1.  N ORN
  1.  S ORN=+$P(FIELDS,U,8)
  1.  I $D(^OR(100,ORN,0)) D
  1.  .S NVSDT=$P(^OR(100,ORN,0),U,8)
  1.  .D WPVAL(.Y,ORN,"STATEMENTS")
  1.  Q
  1.  ;  Return word processing value
  1. WPVAL(Y,ORN,ID) ;
  1.  N DA,I,J
  1.  S DA=+$O(^OR(100,ORN,4.5,"ID",ID,0)),(I,J)=0
  1.  F  S I=$O(^OR(100,ORN,4.5,DA,2,I)) Q:'I  S Y=Y_^(I,0)
  1.  Q
  1.  ; Appends the multiple at the subscript to Y
  1. SETMULT(Y,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_^TMP("PS",$J,INDEX,SUB,I,0)
  1.  Q
  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) ;EP
  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.  Q
  1. GETVMEDE ;NOW GET OUTSIDE MEDS DEFINED AS ANY WITH 1108 FIELD OR EVENT VISIT SERVICE CATEGORY
  1.  K APCHMEDS,APCHM
  1.  D GETMEDS^APCHSMU1(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,,,,,.APCHMEDS)
  1.  ;store each drug by inverse date
  1.  S X=0 F  S X=$O(APCHMEDS(X)) Q:X'=+X  D
  1.  .S M=$P(APCHMEDS(X),U,4)
  1.  .S V=$P(^AUPNVMED(M,0),U,3)
  1.  .I $P(^AUPNVSIT(V,0),U,7)'="E" Q
  1.  .Q:$P($G(^AUPNVMED(M,11)),U,8)]""  ;GOT THESE IN NVA
  1.  .Q:$P(^AUPNVMED(M,0),U,8)  ;discontinued
  1.  .S D=$P(^AUPNVMED(M,0),U,1)
  1.  .S N=$S($P(^AUPNVMED(M,0),U,4)]"":$P(^AUPNVMED(M,0),U,4),1:$P(^PSDRUG(D,0),U,1))
  1.  .Q:$D(APCHALL(N))  ;already have this drug
  1.  .S LINDEX=LINDEX+1
  1.  .S APCHMED(N,LINDEX)=N_U_$P(APCHMEDS(X),U,1)_U_U_$P(^AUPNVMED($P(APCHMEDS(X),U,4),0),U,5)
  1.  Q
  1.  ;
  1. GETEXP ;get expired chronic meds in past 120 days
  1.  ;GET ALL PRESCRIPTIONS IN PHARMACY PATIENT FILE FOR -395 TO TODAY BY EXPIRATION DATE IN PS(55
  1.  K APCHALL,APCHKEEP
  1.  S EXPDT=$$FMADD^XLFDT(DT,-395)
  1.  F  S EXPDT=$O(^PS(55,APCHSDFN,"P","A",EXPDT)) Q:EXPDT'=+EXPDT  D
  1.  .S I=0 F  S I=$O(^PS(55,APCHSDFN,"P","A",EXPDT,I)) Q:I'=+I  D
  1.  ..Q:'$D(^PSRX(I,0))
  1.  ..S D=$P(^PSRX(I,0),U,6)
  1.  ..I '$D(^PSDRUG(D,0)) Q  ;no drug
  1.  ..S N=$P(^PSDRUG(D,0),U)
  1.  ..Q:$D(APCHALL(N))  ;already got this drug
  1.  ..S P=$P(^PSRX(I,0),U,2)
  1.  ..I P'=APCHSDFN Q  ;oops, bad data
  1.  ..S L=$P($G(^PSRX(I,3)),U,1)  ;last dispensed date
  1.  ..I L="" S L=$O(^PSRX(I,1,"B",9999999),-1)
  1.  ..I L="" S L=$P($G(^PSRX(I,2)),U,2)
  1.  ..I L="" S L=$P(^PSRX(I,0),U,13)
  1.  ..Q:L=""
  1.  ..S L=9999999-L
  1.  ..S S=$P($G(^PSRX(I,"STA")),U,1)
  1.  ..Q:S'=11
  1.  ..S APCHALL(N,D,L,I)=S
  1.  ;now kill off all except the latest one
  1.  K APCHKEEP
  1.  S N="" F  S N=$O(APCHALL(N)) Q:N=""  D
  1.  .S D=0 F  S D=$O(APCHALL(N,D)) Q:D=""  D
  1.  ..Q:$D(APCHKEEP(N,D))
  1.  ..S L=$O(APCHALL(N,D,0))
  1.  ..S I=$O(APCHALL(N,D,L,0))
  1.  ..S APCHKEEP(N,D,L,I)=APCHALL(N,D,L,I)
  1.  ;now go through and group them
  1.  S N="" F  S N=$O(APCHKEEP(N)) Q:N=""  D
  1.  .S D=0 F  S D=$O(APCHKEEP(N,D)) Q:D=""  D
  1.  ..S L=0 F  S L=$O(APCHKEEP(N,D,L)) Q:L=""  D
  1.  ...S I=0 F  S I=$O(APCHKEEP(N,D,L,I)) Q:I'=+I  D
  1.  ....S S=APCHKEEP(N,D,L,I)
  1.  ....I S=11 D GRP2 Q
  1.  Q
  1. GRP2 ;
  1.  Q:'$D(^PS(55,APCHSDFN,"P","CP",I))  ;CHRONIC ONLY
  1.  S C=$S(I:$D(^PS(55,APCHSDFN,"P","CP",I)),1:0)
  1.  S Y=$S(C:120,1:14)
  1.  Q:$$FMDIFF^XLFDT(DT,$P($G(^PSRX(I,2)),U,6))>Y
  1.  S LINDEX=LINDEX+1
  1.  S APCHMED(N,D)=N_U_(9999999-L)_U_$P(^PSRX(I,0),U)
  1.  I $O(^PSRX(I,"SIG1",0)) D
  1.  .S S="" S APCHP=0 F  S APCHP=$O(^PSRX(I,"SIG1",APCHP)) Q:APCHP'=+APCHP  S S=S_^PSRX(I,"SIG1",APCHP,0)_" "
  1.  I S="" S S=$P($G(^PSRX(I,"SIG")),U,1)
  1.  S $P(APCHMED(N,LINDEX),U,5)=S
  1.  S APCHSRX=I,APCHSREF=0 D REF^APCHS7O S $P(APCHMED(N,LINDEX),U,4)=APCHSREF
  1.  S $P(APCHMED(N,LINDEX),U,10)=$P($G(^PSRX(I,2)),U,6)  ;expiration date
  1.  Q
  1. DISP ;display them now, this was a pain
  1.  D SUBHEAD^APCHPWHU
  1.  D S^APCHPWH1("MEDICATIONS - This is a list of medications and other items you are")
  1.  D S^APCHPWH1("taking including non-prescription medications, herbal, dietary, and")
  1.  D S^APCHPWH1("traditional supplements.  Please let us know if this list is not ")
  1.  D S^APCHPWH1("complete.  If you have other medications at home or are not sure if")
  1.  D S^APCHPWH1("you should be taking them, call your health care provider to be safe.")
  1.  I '$D(APCHMED) D S^APCHPWH1("No medications are on file.  Please tell us if there are any that we missed.",1) Q
  1.  S APCHC=0
  1.  S APCHN=""
  1.  F  S APCHN=$O(APCHMED(APCHN)) Q:APCHN=""  D
  1.  .S APCHI=0 F  S APCHI=$O(APCHMED(APCHN,APCHI)) Q:APCHI=""  D
  1.  ..S APCHZ=APCHMED(APCHN,APCHI)
  1.  ..S APCHC=APCHC+1
  1.  ..S X="",$E(X,1)=APCHC_"."
  1.  ..S $E(X,7)=$P(APCHZ,U,1) D S^APCHPWH1(X,1)
  1.  ..S X="" I $P(APCHZ,U,3)]""!($P(APCHZ,U,4)]"") S $E(X,7)=$P(APCHZ,U,3)_"     "_$S($P(APCHZ,U,4)]"":"Refills left: "_$P(APCHZ,U,4),1:"") I X]"" D S^APCHPWH1(X)
  1.  ..;attempt to wrap directions 58 characters
  1.  ..K ^UTILITY($J,"W") S X=$P(APCHZ,U,5),DIWL=0,DIWR=58 D ^DIWP
  1.  ..S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
  1.  ..I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
  1.  ..K ^UTILITY($J,"W")
  1.  ..;I $P(Z,U,11)]"" D S^APCHPWH1("      Ordered but not dispensed: "_$P(Z,U,11))
  1.  I '$G(APCHACTO),$D(APCHMEDE) D
  1.  .D S^APCHPWH1("==========",1)
  1.  .D S^APCHPWH1("Your prescription for these medications has expired.  You need to talk")
  1.  .D S^APCHPWH1("with your prescriber to get a new prescription for these medications.")
  1.  .D S^APCHPWH1(" ")
  1.  .S APCHN="" F  S APCHN=$O(APCHMED(2,APCHN)) Q:APCHN=""  D
  1.  ..S APCHI=0 F  S APCHI=$O(APCHMED(2,APCHN,APCHI)) Q:APCHI'=+APCHI  D
  1.  ...S APCHD=0 F  S APCHD=$O(APCHMED(2,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD  D
  1.  ....S APCHZ=APCHMED(2,APCHN,APCHI,APCHD)
  1.  ....S APCHC=APCHC+1
  1.  ....S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(APCHZ,U,6)]"":"Rx#: "_$P(APCHZ,U,6),1:""),$E(X,61)=$S($P(APCHZ,U,7)]"":"Refills left: "_$P(APCHZ,U,7),1:"") D S^APCHPWH1(X,1)
  1.  ....;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
  1.  ....K ^UTILITY($J,"W") S X=$P(APCHZ,U,8),DIWL=0,DIWR=58 D ^DIWP
  1.  ....S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
  1.  ....I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
  1.  ....K ^UTILITY($J,"W")
  1.  ....S X="",$E(X,7)="Last date filled: "_$$FMTE^XLFDT((9999999-APCHD))_"     Expired on: "_$$FMTE^XLFDT($P(APCHZ,U,10)) D S^APCHPWH1(X)
  1.  Q
  1.  ;
  1. SET1 ;
  1.  S $P(APCHMED(Z,N,D,X),U,6)=$P($G(^AUPNVMED(M,11)),U,2)
  1.  S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5)
  1.  S $P(APCHMED(Z,N,D,X),U,7)=$P($G(^AUPNVMED(M,11)),U,7)
  1.  Q
  1. SET ;
  1.  S $P(APCHMED(Z,N,D,X),U,6)=$P(^PSRX(APCHRXN,0),U)
  1.  S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5)
  1.  S APCHSRX=APCHRXN,APCHSREF=0 D REF^APCHS7O S $P(APCHMED(Z,N,D,X),U,7)=APCHSREF
  1.  Q
  1. HOLD(S) ;EP - is this prescription on hold?
  1.  NEW X
  1.  S X=$P($G(^PSRX(S,"STA")),U,1)
  1.  I X=3 Q 1
  1.  ;I X=5 Q 1
  1.  ;I X=16 Q 1
  1.  ;version 6
  1.  S X=$P($G(^PSRX(S,0)),U,15)
  1.  I X=3 Q 1
  1.  ;I X=5 Q 1
  1.  ;I X=16 Q 1
  1.  Q 0