APCDAMED ; IHS/CMI/LAB - PROMPT FOR medication ; 12 Oct 2010 6:46 AM
;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
;
MLUDE ;EP - called from data entry input templates
;get provider who updated and date
;NEW APCDPRBI
;S APCDPRBI=DA
S APCDP=$G(APCDPAT)
I 'APCDP S APCDP=$G(DFN)
S APCDV=$G(APCDVSIT)
S APCDD=$G(APCDDATE)
;
D EN^XBNEW("MLUDE1^APCDAMED","APCDP;APCDV;APCDD;APCDPRBI")
Q
MLUDE1 ;EP - called from xbnew
;get date pl updated
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Medication List was Updated by the Provider"
S DIR("B")=$S($G(APCDD):$$FMTE^XLFDT($P(APCDD,".")),$G(APCDV):$$FMTE^XLFDT($$VD^APCLV(APCDV)),1:$$FMTE^XLFDT(DT)),DIR("?")="This is the visit date or the date the provider updated the medication list. Enter the Time, if known."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G MLUDE1
I $P(Y,".")>DT W !!,"Future Dates now allowed.",! G MLUDE1
S APCDD=Y
MLUDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who Updated the Medication List"
S DIR("B")=$S($G(APCDV):$$PRIMPROV^APCLV(APCDV,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G MLUDE1P
S APCDPRV=+Y
D MLU($G(APCDPRBI),APCDV,APCDP,APCDD,APCDPRV,.APCDRET)
I $P(APCDRET,U,1)=0 W !!,"error: ",$P(APCDRET,U,2)
Q
MLU(APCDPIEN,APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update MEDICATION update fields
;this API can be called to have a V UPDATED/REVIEWED entry and populate the
;.11, .12, and .13 fields
;input: APCDPIEN - ien of medication entry
; APCDV - ien of visit, if in the context of a visit
; APCDP - DFN
; APCDD - Date and optionally time of medication list update (fileman format)
; APCDPRV = ien of provider updating the medication list
;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
;for Provider APCDP on date APCDD
;if not in the context of a visit (APCDV = null) then an event visit will be created
;with a V UPDATED/REVIEWED v file entry
;
;RETURN VALUE:
; ien of V UPDATED/REVIEWED entry that was created
; or 0^error message
S APCDPIEN=$G(APCDPIEN)
S APCDV=$G(APCDV)
S APCDP=$G(APCDP)
I 'APCDP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(APCDP,0)) S RETVAL="0^not a valid patient DFN" Q
S APCDD=$G(APCDD)
I 'APCDD S RETVAL="0^no valid date passed" Q
S APCDPRV=$G(APCDPRV)
I 'APCDPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I APCDV D MLUV Q
;NO VISIT SO CREATE EVENT VISIT AND CALL MLUV
D EVSIT
Q
MLUV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
;not exist on this visit already.
NEW APCDX,APCDVD,APCDVRI,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","MLU",0))
I APCDVAL="" S RETVAL="0^action item missing" Q
S APCDVRI=""
S APCDX=0 F S APCDX=$O(^AUPNVRUP("AD",APCDV,APCDX)) Q:APCDX=""!(APCDVRI) D
.;is this entry a medication list review entry?
.Q:$P(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL ;this one isn't a MLU entry
.Q:$P($G(^AUPNVRUP(APCDX,2)),U,1)
.Q:$P($G(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV ;not this provider
.S APCDVRI=APCDX ;found one so don't create one
.Q
I APCDVRI S RETVAL=APCDVRI Q
;create V UPDATED/REVIEWED entry
NEW APCDALVR
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDVSIT")=APCDV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=APCDD
S APCDALVR("APCDTEPR")="`"_APCDPRV
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
Q
BSD ;
NEW APCDBSDV
K APCDIN
S APCDIN("PAT")=APCDP
S APCDIN("VISIT DATE")=APCDD_".12"
S APCDIN("SITE")=DUZ(2)
S APCDIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDIN("SRV CAT")="E"
S APCDIN("TIME RANGE")=0
S APCDIN("USR")=DUZ
K APCDALVR
K APCDBSDV
D GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
S T=$P(APCDBSDV(0),U,2)
I T]"" S RETVAL="0^could not create event visit" Q ;errored
S V=$O(APCDBSDV(0)) S APCDV=V
I $G(APCDBSDV(V))="ADD" D DEDT^APCDEA2(APCDV)
Q
EVSIT ;EP - get/create event visit
I $L($T(^BSDAPI4)) D Q
.D BSD
.D MLUV
K APCDVSIT
K APCDALVR
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDCAT")="E"
S APCDALVR("APCDLOC")=DUZ(2)
S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDALVR("APCDDATE")=APCDD_".12"
D ^APCDALV
S APCDV=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(APCDVSIT)
K APCDALVR
D MLUV
Q
ANYACTM(APCDSDFN,EDATE) ;EP - medications component
;get all meds in the past year +30 days
NEW APCDMEDS,APCDMED,X,M,I,N,D,APCDKEEP,APCDM,APCDRXN,APCDRXO,APCDRX0,APCDSREF,APCDSTAT,C,APCDN,APCDI,APCDD,APCDC
NEW X,M,D,N,C,Z,P,I,EXPDT,Y
;
;store each drug by inverse date
I '$G(EDATE) S EDATE=DT
K APCDMED,APCDALL
;GET ALL PRESCRIPTIONS IN PHARMACY PATIENT FILE FOR -395 TO TODAY BY EXPIRATION DATE IN PS(55
S EXPDT=$$FMADD^XLFDT(EDATE,-395)
F S EXPDT=$O(^PS(55,APCDSDFN,"P","A",EXPDT)) Q:EXPDT'=+EXPDT D
.S I=0 F S I=$O(^PS(55,APCDSDFN,"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'=APCDSDFN 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 APCDALL(N,D,L,I)=S
;now kill off all except the latest one
K APCDKEEP
S N="" F S N=$O(APCDALL(N)) Q:N="" D
.S D=0 F S D=$O(APCDALL(N,D)) Q:D="" D
..Q:$D(APCDKEEP(N,D))
..S L=$O(APCDALL(N,D,0))
..S I=$O(APCDALL(N,D,L,0))
..S APCDKEEP(N,D,L,I)=APCDALL(N,D,L,I)
;now go through and group them
S N="" F S N=$O(APCDKEEP(N)) Q:N="" D
.S D=0 F S D=$O(APCDKEEP(N,D)) Q:D="" D
..S L=0 F S L=$O(APCDKEEP(N,D,L)) Q:L="" D
...S I=0 F S I=$O(APCDKEEP(N,D,L,I)) Q:I'=+I D
....S S=APCDKEEP(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 APCDMEDS,APCDM
D GETMEDS^APCHSMU1(APCDSDFN,$$FMADD^XLFDT(DT,-365),DT,,,,,.APCDMEDS)
;store each drug by inverse date
S X=0 F S X=$O(APCDMEDS(X)) Q:X'=+X D
.S M=$P(APCDMEDS(X),U,4)
.S V=$P(^AUPNVMED(M,0),U,3)
.I $P(^AUPNVSIT(V,0),U,7)'="E",$P($G(^AUPNVMED(M,11)),U,8)="" Q
.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 APCDM(N,D,(9999999-$P(APCDMEDS(X),U,1)))=APCDMEDS(X)
;now get rid of all except the latest one
K APCDKEEP
S N="" F S N=$O(APCDM(N)) Q:N="" D
.S D=0 F S D=$O(APCDM(N,D)) Q:D="" D
..Q:$D(APCDMED(N,D))
..S X=$O(APCDM(N,D,0))
..S M=$P(APCDM(N,D,X),U,4)
..S APCDMED(1,N,D,X)=M_U_"M"
I $O(APCDMED(0)) Q 1
K APCDMED
;now get all NVA meds that did not move to PCC V MED
S X=0 F S X=$O(^PS(55,APCDSDFN,"NVA",X)) Q:X'=+X D
.I $P($G(^PS(55,APCDSDFN,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,APCDSDFN,"NVA",X,999999911),U,1),0)) Q ;got this with V MED
.S L=$P($P($G(^PS(55,APCDSDFN,"NVA",X,0)),U,10),".")
.S L=9999999-L
.I L<$$FMADD^XLFDT(DT,-365) Q
.Q:$P(^PS(55,APCDSDFN,"NVA",X,0),U,6)=1 ;discontinued
.I $P(^PS(55,APCDSDFN,"NVA",X,0),U,7)]"" ;discontinued date
.S APCDMED(1)=""
I $O(APCDMED(0)) Q 1
;NOW CHECK TO SEE IF THERE ARE ANY MEDS IN V MED IN THE PAST 30 DAYS
K APCDMEDS
D GETMEDS^APCHSMU1(APCDSDFN,$$FMADD^XLFDT(DT,-31),DT,,,,,.APCDMEDS)
I $O(APCDMEDS(0)) Q 2
Q 0
GRP2 ;
Q:'$D(^PS(55,APCDSDFN,"P","CP",I)) ;CHRONIC ONLY
S C=$S(I:$D(^PS(55,APCDSDFN,"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 APCDMED(2,N,D,L)=I_U_"P"
Q
GRP1 ;
S APCDMED(1,N,D,L)=I_U_"P"
Q
MLR(APCDTDA) ;EP - called from nap template to create PLR entry
D EN^XBNEW("MLR1^APCDAMED","APCDTDA")
Q
MLR1 ;
;create MLR entry on this visit
;create V UPDATED/REVIEWED entry
NEW APCDALVR,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","MLR",0))
S APCDALVR("APCDPAT")=$P(^AUPNVRUP(APCDTDA,0),U,2)
S APCDALVR("APCDVSIT")=$P(^AUPNVRUP(APCDTDA,0),U,3)
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=$P($G(^AUPNVRUP(APCDTDA,12)),U,1)
I $P($G(^AUPNVRUP(APCDTDA,12)),U,4) S APCDALVR("APCDTEPR")="`"_$P(^AUPNVRUP(APCDTDA,12),U,4)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
Q
APCDAMED ; IHS/CMI/LAB - PROMPT FOR medication ; 12 Oct 2010 6:46 AM
+1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
+2 ;
MLUDE ;EP - called from data entry input templates
+1 ;get provider who updated and date
+2 ;NEW APCDPRBI
+3 ;S APCDPRBI=DA
+4 SET APCDP=$GET(APCDPAT)
+5 IF 'APCDP
SET APCDP=$GET(DFN)
+6 SET APCDV=$GET(APCDVSIT)
+7 SET APCDD=$GET(APCDDATE)
+8 ;
+9 DO EN^XBNEW("MLUDE1^APCDAMED","APCDP;APCDV;APCDD;APCDPRBI")
+10 QUIT
MLUDE1 ;EP - called from xbnew
+1 ;get date pl updated
+2 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Medication List was Updated by the Provider"
+3 SET DIR("B")=$SELECT($GET(APCDD):$$FMTE^XLFDT($PIECE(APCDD,".")),$GET(APCDV):$$FMTE^XLFDT($$VD^APCLV(APCDV)),1:$$FMTE^XLFDT(DT))
SET DIR("?")="This is the visit date or the date the provider updated the medication list. Enter the Time, if known."
+4 KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO MLUDE1
+6 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates now allowed.",!
GOTO MLUDE1
+7 SET APCDD=Y
MLUDE1P ;GET PROVIDER
+1 SET DIR(0)="9000010.54,1204"
SET DIR("A")="Enter the PROVIDER who Updated the Medication List"
+2 SET DIR("B")=$SELECT($GET(APCDV):$$PRIMPROV^APCLV(APCDV,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO MLUDE1P
+4 SET APCDPRV=+Y
+5 DO MLU($GET(APCDPRBI),APCDV,APCDP,APCDD,APCDPRV,.APCDRET)
+6 IF $PIECE(APCDRET,U,1)=0
WRITE !!,"error: ",$PIECE(APCDRET,U,2)
+7 QUIT
MLU(APCDPIEN,APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update MEDICATION update fields
+1 ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
+2 ;.11, .12, and .13 fields
+3 ;input: APCDPIEN - ien of medication entry
+4 ; APCDV - ien of visit, if in the context of a visit
+5 ; APCDP - DFN
+6 ; APCDD - Date and optionally time of medication list update (fileman format)
+7 ; APCDPRV = ien of provider updating the medication list
+8 ;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
+9 ;for Provider APCDP on date APCDD
+10 ;if not in the context of a visit (APCDV = null) then an event visit will be created
+11 ;with a V UPDATED/REVIEWED v file entry
+12 ;
+13 ;RETURN VALUE:
+14 ; ien of V UPDATED/REVIEWED entry that was created
+15 ; or 0^error message
+16 SET APCDPIEN=$GET(APCDPIEN)
+17 SET APCDV=$GET(APCDV)
+18 SET APCDP=$GET(APCDP)
+19 IF 'APCDP
SET RETVAL="0^not a valid patient DFN"
QUIT
+20 IF '$DATA(^AUPNPAT(APCDP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+21 SET APCDD=$GET(APCDD)
+22 IF 'APCDD
SET RETVAL="0^no valid date passed"
QUIT
+23 SET APCDPRV=$GET(APCDPRV)
+24 IF 'APCDPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+25 SET RETVAL=""
+26 ;
+27 IF APCDV
DO MLUV
QUIT
+28 ;NO VISIT SO CREATE EVENT VISIT AND CALL MLUV
+29 DO EVSIT
+30 QUIT
MLUV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
+1 ;not exist on this visit already.
+2 NEW APCDX,APCDVD,APCDVRI,APCDVAL
+3 SET APCDVAL=$ORDER(^AUTTCRA("C","MLU",0))
+4 IF APCDVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET APCDVRI=""
+6 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVRUP("AD",APCDV,APCDX))
IF APCDX=""!(APCDVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a medication list review entry?
+8 ;this one isn't a MLU entry
IF $PIECE(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL
QUIT
+9 IF $PIECE($GET(^AUPNVRUP(APCDX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV
QUIT
+11 ;found one so don't create one
SET APCDVRI=APCDX
+12 QUIT
End DoDot:1
+13 IF APCDVRI
SET RETVAL=APCDVRI
QUIT
+14 ;create V UPDATED/REVIEWED entry
+15 NEW APCDALVR
+16 SET APCDALVR("APCDPAT")=APCDP
+17 SET APCDALVR("APCDVSIT")=APCDV
+18 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+19 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+20 SET APCDALVR("APCDTCDT")=APCDD
+21 SET APCDALVR("APCDTEPR")="`"_APCDPRV
+22 DO ^APCDALVR
+23 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+24 KILL APCDALVR
+25 QUIT
BSD ;
+1 NEW APCDBSDV
+2 KILL APCDIN
+3 SET APCDIN("PAT")=APCDP
+4 SET APCDIN("VISIT DATE")=APCDD_".12"
+5 SET APCDIN("SITE")=DUZ(2)
+6 SET APCDIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+7 SET APCDIN("SRV CAT")="E"
+8 SET APCDIN("TIME RANGE")=0
+9 SET APCDIN("USR")=DUZ
+10 KILL APCDALVR
+11 KILL APCDBSDV
+12 DO GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
+13 SET T=$PIECE(APCDBSDV(0),U,2)
+14 ;errored
IF T]""
SET RETVAL="0^could not create event visit"
QUIT
+15 SET V=$ORDER(APCDBSDV(0))
SET APCDV=V
+16 IF $GET(APCDBSDV(V))="ADD"
DO DEDT^APCDEA2(APCDV)
+17 QUIT
EVSIT ;EP - get/create event visit
+1 IF $LENGTH($TEXT(^BSDAPI4))
Begin DoDot:1
+2 DO BSD
+3 DO MLUV
End DoDot:1
QUIT
+4 KILL APCDVSIT
+5 KILL APCDALVR
+6 SET APCDALVR("APCDAUTO")=""
+7 SET APCDALVR("APCDPAT")=APCDP
+8 SET APCDALVR("APCDCAT")="E"
+9 SET APCDALVR("APCDLOC")=DUZ(2)
+10 SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+11 SET APCDALVR("APCDDATE")=APCDD_".12"
+12 DO ^APCDALV
+13 SET APCDV=$GET(APCDALVR("APCDVSIT"))
+14 IF $GET(APCDALVR("APCDVSIT","NEW"))
DO DEDT^APCDEA2(APCDVSIT)
+15 KILL APCDALVR
+16 DO MLUV
+17 QUIT
ANYACTM(APCDSDFN,EDATE) ;EP - medications component
+1 ;get all meds in the past year +30 days
+2 NEW APCDMEDS,APCDMED,X,M,I,N,D,APCDKEEP,APCDM,APCDRXN,APCDRXO,APCDRX0,APCDSREF,APCDSTAT,C,APCDN,APCDI,APCDD,APCDC
+3 NEW X,M,D,N,C,Z,P,I,EXPDT,Y
+4 ;
+5 ;store each drug by inverse date
+6 IF '$GET(EDATE)
SET EDATE=DT
+7 KILL APCDMED,APCDALL
+8 ;GET ALL PRESCRIPTIONS IN PHARMACY PATIENT FILE FOR -395 TO TODAY BY EXPIRATION DATE IN PS(55
+9 SET EXPDT=$$FMADD^XLFDT(EDATE,-395)
+10 FOR
SET EXPDT=$ORDER(^PS(55,APCDSDFN,"P","A",EXPDT))
IF EXPDT'=+EXPDT
QUIT
Begin DoDot:1
+11 SET I=0
FOR
SET I=$ORDER(^PS(55,APCDSDFN,"P","A",EXPDT,I))
IF I'=+I
QUIT
Begin DoDot:2
+12 IF '$DATA(^PSRX(I,0))
QUIT
+13 SET D=$PIECE(^PSRX(I,0),U,6)
+14 ;no drug
IF '$DATA(^PSDRUG(D,0))
QUIT
+15 SET N=$PIECE(^PSDRUG(D,0),U)
+16 SET P=$PIECE(^PSRX(I,0),U,2)
+17 ;oops, bad data
IF P'=APCDSDFN
QUIT
+18 ;last dispensed date
SET L=$PIECE($GET(^PSRX(I,3)),U,1)
+19 IF L=""
SET L=$ORDER(^PSRX(I,1,"B",9999999),-1)
+20 IF L=""
SET L=$PIECE($GET(^PSRX(I,2)),U,2)
+21 IF L=""
SET L=$PIECE(^PSRX(I,0),U,13)
+22 IF L=""
QUIT
+23 SET L=9999999-L
+24 SET S=$PIECE($GET(^PSRX(I,"STA")),U,1)
+25 IF S=1
QUIT
+26 IF S=4
QUIT
+27 IF S=10
QUIT
+28 IF S=12
QUIT
+29 IF S=13
QUIT
+30 IF S=14
QUIT
+31 IF S=15
QUIT
+32 IF S=16
QUIT
+33 SET APCDALL(N,D,L,I)=S
End DoDot:2
End DoDot:1
+34 ;now kill off all except the latest one
+35 KILL APCDKEEP
+36 SET N=""
FOR
SET N=$ORDER(APCDALL(N))
IF N=""
QUIT
Begin DoDot:1
+37 SET D=0
FOR
SET D=$ORDER(APCDALL(N,D))
IF D=""
QUIT
Begin DoDot:2
+38 IF $DATA(APCDKEEP(N,D))
QUIT
+39 SET L=$ORDER(APCDALL(N,D,0))
+40 SET I=$ORDER(APCDALL(N,D,L,0))
+41 SET APCDKEEP(N,D,L,I)=APCDALL(N,D,L,I)
End DoDot:2
End DoDot:1
+42 ;now go through and group them
+43 SET N=""
FOR
SET N=$ORDER(APCDKEEP(N))
IF N=""
QUIT
Begin DoDot:1
+44 SET D=0
FOR
SET D=$ORDER(APCDKEEP(N,D))
IF D=""
QUIT
Begin DoDot:2
+45 SET L=0
FOR
SET L=$ORDER(APCDKEEP(N,D,L))
IF L=""
QUIT
Begin DoDot:3
+46 SET I=0
FOR
SET I=$ORDER(APCDKEEP(N,D,L,I))
IF I'=+I
QUIT
Begin DoDot:4
+47 SET S=APCDKEEP(N,D,L,I)
+48 IF S=11
DO GRP2
QUIT
+49 DO GRP1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 ;NOW GET OUTSIDE MEDS DEFINED AS ANY WITH 1108 FIELD OR EVENT VISIT SERVICE CATEGORY
+51 KILL APCDMEDS,APCDM
+52 DO GETMEDS^APCHSMU1(APCDSDFN,$$FMADD^XLFDT(DT,-365),DT,,,,,.APCDMEDS)
+53 ;store each drug by inverse date
+54 SET X=0
FOR
SET X=$ORDER(APCDMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+55 SET M=$PIECE(APCDMEDS(X),U,4)
+56 SET V=$PIECE(^AUPNVMED(M,0),U,3)
+57 IF $PIECE(^AUPNVSIT(V,0),U,7)'="E"
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 APCDM(N,D,(9999999-$PIECE(APCDMEDS(X),U,1)))=APCDMEDS(X)
End DoDot:1
+62 ;now get rid of all except the latest one
+63 KILL APCDKEEP
+64 SET N=""
FOR
SET N=$ORDER(APCDM(N))
IF N=""
QUIT
Begin DoDot:1
+65 SET D=0
FOR
SET D=$ORDER(APCDM(N,D))
IF D=""
QUIT
Begin DoDot:2
+66 IF $DATA(APCDMED(N,D))
QUIT
+67 SET X=$ORDER(APCDM(N,D,0))
+68 SET M=$PIECE(APCDM(N,D,X),U,4)
+69 SET APCDMED(1,N,D,X)=M_U_"M"
End DoDot:2
End DoDot:1
+70 IF $ORDER(APCDMED(0))
QUIT 1
+71 KILL APCDMED
+72 ;now get all NVA meds that did not move to PCC V MED
+73 SET X=0
FOR
SET X=$ORDER(^PS(55,APCDSDFN,"NVA",X))
IF X'=+X
QUIT
Begin DoDot:1
+74 ;got this with V MED
IF $PIECE($GET(^PS(55,APCDSDFN,"NVA",X,999999911)),U,1)
IF $DATA(^AUPNVMED($PIECE(^PS(55,APCDSDFN,"NVA",X,999999911),U,1),0))
QUIT
+75 SET L=$PIECE($PIECE($GET(^PS(55,APCDSDFN,"NVA",X,0)),U,10),".")
+76 SET L=9999999-L
+77 IF L<$$FMADD^XLFDT(DT,-365)
QUIT
+78 ;discontinued
IF $PIECE(^PS(55,APCDSDFN,"NVA",X,0),U,6)=1
QUIT
+79 ;discontinued date
IF $PIECE(^PS(55,APCDSDFN,"NVA",X,0),U,7)]""
+80 SET APCDMED(1)=""
End DoDot:1
+81 IF $ORDER(APCDMED(0))
QUIT 1
+82 ;NOW CHECK TO SEE IF THERE ARE ANY MEDS IN V MED IN THE PAST 30 DAYS
+83 KILL APCDMEDS
+84 DO GETMEDS^APCHSMU1(APCDSDFN,$$FMADD^XLFDT(DT,-31),DT,,,,,.APCDMEDS)
+85 IF $ORDER(APCDMEDS(0))
QUIT 2
+86 QUIT 0
GRP2 ;
+1 ;CHRONIC ONLY
IF '$DATA(^PS(55,APCDSDFN,"P","CP",I))
QUIT
+2 SET C=$SELECT(I:$DATA(^PS(55,APCDSDFN,"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 APCDMED(2,N,D,L)=I_U_"P"
+6 QUIT
GRP1 ;
+1 SET APCDMED(1,N,D,L)=I_U_"P"
+2 QUIT
MLR(APCDTDA) ;EP - called from nap template to create PLR entry
+1 DO EN^XBNEW("MLR1^APCDAMED","APCDTDA")
+2 QUIT
MLR1 ;
+1 ;create MLR entry on this visit
+2 ;create V UPDATED/REVIEWED entry
+3 NEW APCDALVR,APCDVAL
+4 SET APCDVAL=$ORDER(^AUTTCRA("C","MLR",0))
+5 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVRUP(APCDTDA,0),U,2)
+6 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVRUP(APCDTDA,0),U,3)
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+8 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+9 SET APCDALVR("APCDTCDT")=$PIECE($GET(^AUPNVRUP(APCDTDA,12)),U,1)
+10 IF $PIECE($GET(^AUPNVRUP(APCDTDA,12)),U,4)
SET APCDALVR("APCDTEPR")="`"_$PIECE(^AUPNVRUP(APCDTDA,12),U,4)
+11 DO ^APCDALVR
+12 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+13 KILL APCDALVR
+14 QUIT
