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