APCHPWHX ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;**2,5,7,8,10**;MAY 14, 2009;Build 88
;
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
;
;store each drug by inverse date
K APCHMED,APCHALL
;GET ALL PRESCRIPTIONS IN PHARMACY PATIENT FILE FOR -395 TO TODAY BY EXPIRATION DATE IN PS(55
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)
..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=1
..Q:S=4
..Q:S=10
..Q:S=12
..Q:S=13
..Q:S=14
..Q:S=15
..Q:S=16
..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
....D GRP1
;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)]"" ;will get this one from 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))
.S APCHM(N,D,(9999999-$P(APCHMEDS(X),U,1)))=APCHMEDS(X)
;now get rid of all except the latest one
K APCHKEEP
S N="" F S N=$O(APCHM(N)) Q:N="" D
.S D=0 F S D=$O(APCHM(N,D)) Q:D="" D
..Q:$D(APCHMED(N,D))
..S X=$O(APCHM(N,D,0))
..S M=$P(APCHM(N,D,X),U,4)
..S APCHMED(1,N,D,X)=M_U_"M"
..S $P(APCHMED(1,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5)
;now get all NVA meds
NEW NVA0,ORDNUM,APCHVM,SIG
S X=0 F S X=$O(^PS(55,APCHSDFN,"NVA",X)) Q:X'=+X D
.S APCHVM=""
.;I $P($G(^PS(55,APCHSDFN,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCHSDFN,"NVA",X,999999911),U,1),0)) S APCHVM=$P(^PS(55,APCHSDFN,"NVA",X,999999911),U,1) Q ;got this with V MED
.S L=$P($P($G(^PS(55,APCHSDFN,"NVA",X,0)),U,10),".")
.;S L=9999999-L
.;I L<$$FMADD^XLFDT(DT,-365) Q
.Q:$P(^PS(55,APCHSDFN,"NVA",X,0),U,6)=1 ;discontinued
.I $P(^PS(55,APCHSDFN,"NVA",X,0),U,7)]"" Q ;discontinued date
.S D=$P(^PS(55,APCHSDFN,"NVA",X,0),U,2)
.I D="" S D="NO DRUG IEN"
.S N=$S(D:$P(^PSDRUG(D,0),U,1),1:$P(^PS(50.7,$P(^PS(55,APCHSDFN,"NVA",X,0),U,1),0),U,1))
.;FIGURE OUT SIG COPIED FROM APSPPCC2
.S NVA0=$G(^PS(55,APCHSDFN,"NVA",X,0))
.S ORDNUM=$P(NVA0,U,8)
.S SIG=$$SIG(ORDNUM)
.S APCHSTAT("NVA",N,D,(9999999-L))=U_"N",$P(APCHSTAT("NVA",N,D,(9999999-L)),U,8)=$P(^PS(55,APCHSDFN,"NVA",X,0),U,4)_" "_$P(^PS(55,APCHSDFN,"NVA",X,0),U,5)_U_$P(^PS(55,APCHSDFN,"NVA",X,0),U,7)
.S APCHMED(1,N,D,(9999999-L))=U_"N",$P(APCHMED(1,N,D,(9999999-L)),U,8)=SIG_" "_$P(^PS(55,APCHSDFN,"NVA",X,0),U,5)_U_$P(^PS(55,APCHSDFN,"NVA",X,0),U,7)
D DISP
Q
; Return SIG from Order
SIG(ORIFN) ;EP
N ID,LP,SIG
Q:'$G(ORIFN) ""
S ID=$$PTR(ORIFN,"SIG")
Q:'ID ""
S SIG=""
S LP=0 F S LP=$O(^OR(100,ORIFN,4.5,ID,2,LP)) Q:'LP D
.S SIG=SIG_$S($L(SIG):" ",1:"")_^OR(100,ORIFN,4.5,ID,2,LP,0)
Q SIG
PTR(ORIFN,ID) S ID=$O(^OR(100,ORIFN,4.5,"ID",ID,0))
Q ID
;
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 APCHMED(2,N,D,L)=I_U_"P"
S $P(APCHMED(2,N,D,L),U,6)=$P(^PSRX(I,0),U)
;S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5) ;SET SIG
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(2,N,D,L),U,8)=S
S APCHSRX=I,APCHSREF=0 D REF^APCHS7O S $P(APCHMED(2,N,D,L),U,7)=APCHSREF
S $P(APCHMED(2,N,D,L),U,10)=$P($G(^PSRX(I,2)),U,6) ;expiration date
Q
GRP1 ;
S APCHMED(1,N,D,L)=I_U_"P"
S $P(APCHMED(1,N,D,L),U,6)=$P(^PSRX(I,0),U)
;S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5) ;SET SIG
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(1,N,D,L),U,8)=S
S APCHSRX=I,APCHSREF=0 D REF^APCHS7O S $P(APCHMED(1,N,D,L),U,7)=APCHSREF
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(1,APCHN)) Q:APCHN="" D
.S APCHI=0 F S APCHI=$O(APCHMED(1,APCHN,APCHI)) Q:APCHI="" D
..S APCHD=0 F S APCHD=$O(APCHMED(1,APCHN,APCHI,APCHD)) Q:APCHD="" D
...S APCHZ=APCHMED(1,APCHN,APCHI,APCHD)
...S APCHC=APCHC+1
...S X="",$E(X,1)=APCHC_"."
...S $E(X,7)=APCHN,$E(X,47)=$S($P(APCHZ,U,2)="P":"Rx#: "_$P(^PSRX($P(APCHZ,U,1),0),U,1),$P(APCHZ,U,2)="M":$P($G(^AUPNVMED($P(APCHZ,U,1),11)),U,2),1:"")
...S $E(X,61)=$S($P(APCHZ,U,7)]"":"Refills left: "_$P(APCHZ,U,7),1:"") D S^APCHPWH1(X,1)
...;attempt to wrap directions 58 characters
...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")
...;I $P(Z,U,11)]"" D S^APCHPWH1(" Ordered but not dispensed: "_$P(Z,U,11))
I '$G(APCHACTO),$D(APCHMED(2)) 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)
;I $D(APCHMED(3)) D
;.D S^APCHPWH1("==========",1)
;.D S^APCHPWH1("These medications have been stopped. You should not take these")
;.D S^APCHPWH1("medications. Talk to your pharmacist about ways to safely get rid")
;.D S^APCHPWH1("of these medications if you have them at home.")
;.D S^APCHPWH1(" ")
;.S APCHN="" F S APCHN=$O(APCHMED(3,APCHN)) Q:APCHN="" D
;..S APCHI=0 F S APCHI=$O(APCHMED(3,APCHN,APCHI)) Q:APCHI'=+APCHI D
;...S APCHD=0 F S APCHD=$O(APCHMED(3,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD D
;....S Z=APCHMED(3,APCHN,APCHI,APCHD)
;....S APCHC=APCHC+1
;....S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(Z,U,6)]"":"Rx#: "_$P(Z,U,6),1:""),$E(X,61)=$S($P(Z,U,7)]"":"Refills left: "_$P(Z,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(Z,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)="Discontinued on: "_$$FMTE^XLFDT($P(Z,U,12)) 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
APCHPWHX ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**2,5,7,8,10**;MAY 14, 2009;Build 88
+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 ;store each drug by inverse date
+6 KILL APCHMED,APCHALL
+7 ;GET ALL PRESCRIPTIONS IN PHARMACY PATIENT FILE FOR -395 TO TODAY BY EXPIRATION DATE IN PS(55
+8 SET EXPDT=$$FMADD^XLFDT(DT,-395)
+9 FOR
SET EXPDT=$ORDER(^PS(55,APCHSDFN,"P","A",EXPDT))
IF EXPDT'=+EXPDT
QUIT
Begin DoDot:1
+10 SET I=0
FOR
SET I=$ORDER(^PS(55,APCHSDFN,"P","A",EXPDT,I))
IF I'=+I
QUIT
Begin DoDot:2
+11 IF '$DATA(^PSRX(I,0))
QUIT
+12 SET D=$PIECE(^PSRX(I,0),U,6)
+13 ;no drug
IF '$DATA(^PSDRUG(D,0))
QUIT
+14 SET N=$PIECE(^PSDRUG(D,0),U)
+15 SET P=$PIECE(^PSRX(I,0),U,2)
+16 ;oops, bad data
IF P'=APCHSDFN
QUIT
+17 ;last dispensed date
SET L=$PIECE($GET(^PSRX(I,3)),U,1)
+18 IF L=""
SET L=$ORDER(^PSRX(I,1,"B",9999999),-1)
+19 IF L=""
SET L=$PIECE($GET(^PSRX(I,2)),U,2)
+20 IF L=""
SET L=$PIECE(^PSRX(I,0),U,13)
+21 IF L=""
QUIT
+22 SET L=9999999-L
+23 SET S=$PIECE($GET(^PSRX(I,"STA")),U,1)
+24 IF S=1
QUIT
+25 IF S=4
QUIT
+26 IF S=10
QUIT
+27 IF S=12
QUIT
+28 IF S=13
QUIT
+29 IF S=14
QUIT
+30 IF S=15
QUIT
+31 IF S=16
QUIT
+32 SET APCHALL(N,D,L,I)=S
End DoDot:2
End DoDot:1
+33 ;now kill off all except the latest one
+34 KILL APCHKEEP
+35 SET N=""
FOR
SET N=$ORDER(APCHALL(N))
IF N=""
QUIT
Begin DoDot:1
+36 SET D=0
FOR
SET D=$ORDER(APCHALL(N,D))
IF D=""
QUIT
Begin DoDot:2
+37 IF $DATA(APCHKEEP(N,D))
QUIT
+38 SET L=$ORDER(APCHALL(N,D,0))
+39 SET I=$ORDER(APCHALL(N,D,L,0))
+40 SET APCHKEEP(N,D,L,I)=APCHALL(N,D,L,I)
End DoDot:2
End DoDot:1
+41 ;now go through and group them
+42 SET N=""
FOR
SET N=$ORDER(APCHKEEP(N))
IF N=""
QUIT
Begin DoDot:1
+43 SET D=0
FOR
SET D=$ORDER(APCHKEEP(N,D))
IF D=""
QUIT
Begin DoDot:2
+44 SET L=0
FOR
SET L=$ORDER(APCHKEEP(N,D,L))
IF L=""
QUIT
Begin DoDot:3
+45 SET I=0
FOR
SET I=$ORDER(APCHKEEP(N,D,L,I))
IF I'=+I
QUIT
Begin DoDot:4
+46 SET S=APCHKEEP(N,D,L,I)
+47 IF S=11
DO GRP2
QUIT
+48 DO GRP1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;NOW GET OUTSIDE MEDS DEFINED AS ANY WITH 1108 FIELD OR EVENT VISIT SERVICE CATEGORY
+50 KILL APCHMEDS,APCHM
+51 DO GETMEDS^APCHSMU1(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,,,,,.APCHMEDS)
+52 ;store each drug by inverse date
+53 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+54 SET M=$PIECE(APCHMEDS(X),U,4)
+55 SET V=$PIECE(^AUPNVMED(M,0),U,3)
+56 IF $PIECE(^AUPNVSIT(V,0),U,7)'="E"
QUIT
+57 ;will get this one from NVA
IF $PIECE($GET(^AUPNVMED(M,11)),U,8)]""
QUIT
+58 ;discontinued
IF $PIECE(^AUPNVMED(M,0),U,8)
QUIT
+59 SET D=$PIECE(^AUPNVMED(M,0),U,1)
+60 SET N=$SELECT($PIECE(^AUPNVMED(M,0),U,4)]"":$PIECE(^AUPNVMED(M,0),U,4),1:$PIECE(^PSDRUG(D,0),U,1))
+61 SET APCHM(N,D,(9999999-$PIECE(APCHMEDS(X),U,1)))=APCHMEDS(X)
End DoDot:1
+62 ;now get rid of all except the latest one
+63 KILL APCHKEEP
+64 SET N=""
FOR
SET N=$ORDER(APCHM(N))
IF N=""
QUIT
Begin DoDot:1
+65 SET D=0
FOR
SET D=$ORDER(APCHM(N,D))
IF D=""
QUIT
Begin DoDot:2
+66 IF $DATA(APCHMED(N,D))
QUIT
+67 SET X=$ORDER(APCHM(N,D,0))
+68 SET M=$PIECE(APCHM(N,D,X),U,4)
+69 SET APCHMED(1,N,D,X)=M_U_"M"
+70 SET $PIECE(APCHMED(1,N,D,X),U,8)=$PIECE(^AUPNVMED(M,0),U,5)
End DoDot:2
End DoDot:1
+71 ;now get all NVA meds
+72 NEW NVA0,ORDNUM,APCHVM,SIG
+73 SET X=0
FOR
SET X=$ORDER(^PS(55,APCHSDFN,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+74 SET APCHVM=""
+75 ;I $P($G(^PS(55,APCHSDFN,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCHSDFN,"NVA",X,999999911),U,1),0)) S APCHVM=$P(^PS(55,APCHSDFN,"NVA",X,999999911),U,1) Q ;got this with V MED
+76 SET L=$PIECE($PIECE($GET(^PS(55,APCHSDFN,"NVA",X,0)),U,10),".")
+77 ;S L=9999999-L
+78 ;I L<$$FMADD^XLFDT(DT,-365) Q
+79 ;discontinued
IF $PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,6)=1
QUIT
+80 ;discontinued date
IF $PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,7)]""
QUIT
+81 SET D=$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,2)
+82 IF D=""
SET D="NO DRUG IEN"
+83 SET N=$SELECT(D:$PIECE(^PSDRUG(D,0),U,1),1:$PIECE(^PS(50.7,$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,1),0),U,1))
+84 ;FIGURE OUT SIG COPIED FROM APSPPCC2
+85 SET NVA0=$GET(^PS(55,APCHSDFN,"NVA",X,0))
+86 SET ORDNUM=$PIECE(NVA0,U,8)
+87 SET SIG=$$SIG(ORDNUM)
+88 SET APCHSTAT("NVA",N,D,(9999999-L))=U_"N"
SET $PIECE(APCHSTAT("NVA",N,D,(9999999-L)),U,8)=$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,4)_" "_$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,5)_U_$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,7)
+89 SET APCHMED(1,N,D,(9999999-L))=U_"N"
SET $PIECE(APCHMED(1,N,D,(9999999-L)),U,8)=SIG_" "_$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,5)_U_$PIECE(^PS(55,APCHSDFN,"NVA",X,0),U,7)
End DoDot:1
+90 DO DISP
+91 QUIT
+92 ; Return SIG from Order
SIG(ORIFN) ;EP
+1 NEW ID,LP,SIG
+2 IF '$GET(ORIFN)
QUIT ""
+3 SET ID=$$PTR(ORIFN,"SIG")
+4 IF 'ID
QUIT ""
+5 SET SIG=""
+6 SET LP=0
FOR
SET LP=$ORDER(^OR(100,ORIFN,4.5,ID,2,LP))
IF 'LP
QUIT
Begin DoDot:1
+7 SET SIG=SIG_$SELECT($LENGTH(SIG):" ",1:"")_^OR(100,ORIFN,4.5,ID,2,LP,0)
End DoDot:1
+8 QUIT SIG
PTR(ORIFN,ID) SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID",ID,0))
+1 QUIT ID
+2 ;
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 APCHMED(2,N,D,L)=I_U_"P"
+6 SET $PIECE(APCHMED(2,N,D,L),U,6)=$PIECE(^PSRX(I,0),U)
+7 ;S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5) ;SET SIG
+8 IF $ORDER(^PSRX(I,"SIG1",0))
Begin DoDot:1
+9 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
+10 IF S=""
SET S=$PIECE($GET(^PSRX(I,"SIG")),U,1)
+11 SET $PIECE(APCHMED(2,N,D,L),U,8)=S
+12 SET APCHSRX=I
SET APCHSREF=0
DO REF^APCHS7O
SET $PIECE(APCHMED(2,N,D,L),U,7)=APCHSREF
+13 ;expiration date
SET $PIECE(APCHMED(2,N,D,L),U,10)=$PIECE($GET(^PSRX(I,2)),U,6)
+14 QUIT
GRP1 ;
+1 SET APCHMED(1,N,D,L)=I_U_"P"
+2 SET $PIECE(APCHMED(1,N,D,L),U,6)=$PIECE(^PSRX(I,0),U)
+3 ;S $P(APCHMED(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5) ;SET SIG
+4 IF $ORDER(^PSRX(I,"SIG1",0))
Begin DoDot:1
+5 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
+6 IF S=""
SET S=$PIECE($GET(^PSRX(I,"SIG")),U,1)
+7 SET $PIECE(APCHMED(1,N,D,L),U,8)=S
+8 SET APCHSRX=I
SET APCHSREF=0
DO REF^APCHS7O
SET $PIECE(APCHMED(1,N,D,L),U,7)=APCHSREF
+9 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(1,APCHN))
IF APCHN=""
QUIT
Begin DoDot:1
+11 SET APCHI=0
FOR
SET APCHI=$ORDER(APCHMED(1,APCHN,APCHI))
IF APCHI=""
QUIT
Begin DoDot:2
+12 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHMED(1,APCHN,APCHI,APCHD))
IF APCHD=""
QUIT
Begin DoDot:3
+13 SET APCHZ=APCHMED(1,APCHN,APCHI,APCHD)
+14 SET APCHC=APCHC+1
+15 SET X=""
SET $EXTRACT(X,1)=APCHC_"."
+16 SET $EXTRACT(X,7)=APCHN
SET $EXTRACT(X,47)=$SELECT($PIECE(APCHZ,U,2)="P":"Rx#: "_$PIECE(^PSRX($PIECE(APCHZ,U,1),0),U,1),$PIECE(APCHZ,U,2)="M":$PIECE($GET(^AUPNVMED($PIECE(APCHZ,U,1),11)),U,2),1:"")
+17 SET $EXTRACT(X,61)=$SELECT($PIECE(APCHZ,U,7)]"":"Refills left: "_$PIECE(APCHZ,U,7),1:"")
DO S^APCHPWH1(X,1)
+18 ;attempt to wrap directions 58 characters
+19 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(APCHZ,U,8)
SET DIWL=0
SET DIWR=58
DO ^DIWP
+20 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)
+21 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)
+22 KILL ^UTILITY($JOB,"W")
+23 ;I $P(Z,U,11)]"" D S^APCHPWH1(" Ordered but not dispensed: "_$P(Z,U,11))
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF '$GET(APCHACTO)
IF $DATA(APCHMED(2))
Begin DoDot:1
+25 DO S^APCHPWH1("==========",1)
+26 DO S^APCHPWH1("Your prescription for these medications has expired. You need to talk")
+27 DO S^APCHPWH1("with your prescriber to get a new prescription for these medications.")
+28 DO S^APCHPWH1(" ")
+29 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHMED(2,APCHN))
IF APCHN=""
QUIT
Begin DoDot:2
+30 SET APCHI=0
FOR
SET APCHI=$ORDER(APCHMED(2,APCHN,APCHI))
IF APCHI'=+APCHI
QUIT
Begin DoDot:3
+31 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHMED(2,APCHN,APCHI,APCHD))
IF APCHD'=+APCHD
QUIT
Begin DoDot:4
+32 SET APCHZ=APCHMED(2,APCHN,APCHI,APCHD)
+33 SET APCHC=APCHC+1
+34 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)
+35 ;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
+36 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(APCHZ,U,8)
SET DIWL=0
SET DIWR=58
DO ^DIWP
+37 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)
+38 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)
+39 KILL ^UTILITY($JOB,"W")
+40 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
+41 ;I $D(APCHMED(3)) D
+42 ;.D S^APCHPWH1("==========",1)
+43 ;.D S^APCHPWH1("These medications have been stopped. You should not take these")
+44 ;.D S^APCHPWH1("medications. Talk to your pharmacist about ways to safely get rid")
+45 ;.D S^APCHPWH1("of these medications if you have them at home.")
+46 ;.D S^APCHPWH1(" ")
+47 ;.S APCHN="" F S APCHN=$O(APCHMED(3,APCHN)) Q:APCHN="" D
+48 ;..S APCHI=0 F S APCHI=$O(APCHMED(3,APCHN,APCHI)) Q:APCHI'=+APCHI D
+49 ;...S APCHD=0 F S APCHD=$O(APCHMED(3,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD D
+50 ;....S Z=APCHMED(3,APCHN,APCHI,APCHD)
+51 ;....S APCHC=APCHC+1
+52 ;....S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(Z,U,6)]"":"Rx#: "_$P(Z,U,6),1:""),$E(X,61)=$S($P(Z,U,7)]"":"Refills left: "_$P(Z,U,7),1:"") D S^APCHPWH1(X,1)
+53 ;....;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
+54 ;....K ^UTILITY($J,"W") S X=$P(Z,U,8),DIWL=0,DIWR=58 D ^DIWP
+55 ;....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)
+56 ;....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)
+57 ;....K ^UTILITY($J,"W")
+58 ;....S X="",$E(X,7)="Discontinued on: "_$$FMTE^XLFDT($P(Z,U,12)) D S^APCHPWH1(X)
+59 QUIT
+60 ;
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
