VENPCC1H ; IHS/OIT/GIS - MORE ENCOUNTER FORM DATA MINING ;
;;2.6;PCC+;;NOV 12, 2007
; PATCHED BY GIS 12/9/04 TO ADD RX PROVIDER. CLEANED UP RX CODE
;
; PROCESS PROBLEMS AND MED FOR VER 2.5
;
DX(PRV,DFN) ; EP-GET PREFERRED DIAGNOSES
NEW DIEN,GENERIC,ICD,IIEN,NAME,PTYPE,TOT,VAR,VAR1,X,%,INDX
S PTYPE=$$CLASS(DFN) I PTYPE="" S STOP=1 Q
S INDX=PRV_"."_PTYPE
I '$D(^VEN(7.1,"AG",INDX)) S INDX=$$CP^VENPCCU(+$G(DEPTIEN))_"."_PTYPE
I '$D(^VEN(7.1,"AG",INDX)) S INDX=$$GP^VENPCCU_"."_PTYPE
S DIEN=0 F TOT=1:1:60 S DIEN=$O(^VEN(7.1,"AG",INDX,DIEN)) Q:'DIEN D
. S X=$G(^VEN(7.1,DIEN,0)),ICD=$P(X,U,2),NAME=$P(X,U,3) I '$L(NAME) Q
. S NAME=$TR(NAME,$C(34),""),NAME=$E(NAME,1,27)
. S VAR="d"_TOT,VAR1=VAR_"c"
. S @TMP@(1,VAR)=NAME,@TMP@(1,VAR1)=ICD
. Q
K @TMP@(0)
Q
;
PROB(DFN) ; EP-GET ACTIVE PROBLEMS
I $G(DEFEF),$G(DEPTIEN),$P($G(^VEN(7.41,DEFEF,5)),U,17),$L($T(PROB^VENPCC1K)) D PROB^VENPCC1K(DFN,DEPTIEN) Q ; ALTERNATE PROBLEM LOOKUP
NEW %,ICD,ICD9,IIEN,NARR,NIEN,PIEN,STAT,STOP,TOT,TYPE,VAR,VAR1,X,FVFLAG,MAXNARR,MAX
S TOT=0,PIEN=999999999,MAXNARR=$$MAXNARR^VENPCCU(+$G(DEFEF))
S MAX=$P($G(^VEN(7.41,DEFEF,1)),U) I 'MAX S MAX=20 ; MAX # PROBS DISPLAYED ; PATCHED BY GIS/OIT 10/15/05 ; PCC+ 2.5 PATCH 1
F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN),-1) Q:'PIEN D I $G(STOP) Q
. S X=$G(^AUPNPROB(PIEN,0)),NIEN=$P(X,U,5),IIEN=+X,STAT=$P(X,U,12),TYPE=$P(X,4,U)
. I NIEN,IIEN,STAT="A",TYPE=""
. E Q
. S NARR=$G(^AUTNPOV(NIEN,0)),ICD=$P($G(^ICD9(IIEN,0)),U),ICD9(IIEN)="" ; MARK THE ICD
. S %="" I $P($G(^VEN(7.41,DEFEF,2)),U,12) S %=$P($G(^AUPNPROB(PIEN,0)),U,13) ; DATE OF ONSET REQUESTED
. I % S NARR=NARR_" (Onset: "_$$FMTE^XLFDT(%,"1D")_")" ; APPEND DATE OF ONSET
. S TOT=TOT+1 I TOT=MAX S STOP=1
. S VAR="p"_TOT,VAR1=VAR_"c"
. S @TMP@(1,VAR)=$E(NARR,1,MAXNARR),@TMP@(1,VAR1)=ICD
. Q
I $P($G(^VEN(7.41,DEFEF,2)),U,13) Q ; OPTION TO DISPLAY ONLY PROBLEMS - NO POVS
POV ; ADD POVS TO THE LIST
I TOT>(MAX-3) Q
S TOT=TOT+1,%="",$P(%,"-",15)="",%=%_"POVs"_%
S @TMP@(1,("p"_TOT))=$E(%,1,40),@TMP@(1,"p"_TOT_"c")=$E(%,1,8) ; INSERT THE POV DIVIDER LINE
F S PIEN=$O(^AUPNVPOV("AC",DFN,PIEN),-1) Q:'PIEN D I $G(STOP) Q ; GET MOST RECENT POVS UP TO MAX #
. S X=$G(^AUPNVPOV(PIEN,0)),NIEN=$P(X,U,4),IIEN=+X
. I $D(ICD9(IIEN)) Q ; DONT ADD POV IF ITS ALREADY IN THE LIST!
. S ICD9(IIEN)=""
. S NARR=$G(^AUTNPOV(+$G(NIEN),0))
. S ICD=$$FVICD^VENPCCU(PIEN) ; GET ICD CODE OR BLOCK ICD CODE OF A "FOREIGN" VISIT
. I '$L(NARR) S NARR=$P($G(^ICD9(IIEN,0)),U,3) I '$L(NARR) S NARR="<missing narrative>"
. S TOT=TOT+1 I TOT=MAX S STOP=1
. S VAR="p"_TOT,VAR1=VAR_"c"
. S @TMP@(1,VAR)=$E(NARR,1,MAXNARR),@TMP@(1,VAR1)=ICD
. Q
I '$G(HDR25) Q ; CHECK TO SEE IF EXTENDED HEADER FILE IS IN USE
D POV^VENPCC1K(DFN) ; GET 30 MOST RECENT POVS
D CSPOV^VENPCC1K(DFN,DEPTIEN) ; GET 30 MOST RECENT CLINIC-SPECIFIC POVS
D MH^VENPCC1K(DFN) ; GER 15 MOST RECENT MENTAL HEALTH POVS
Q
;
MED(PRV,DFN) ; EP-GET RECENT MEDS
N DATE,DAYS,DCD,EXT,MED,MIEN,QTY,RIEN,SIG,STOP,TOT,VAR,VIEN,SCAT,NTRX
N X,X1,X2,REM,IDT,MAX,PER,STAT,REF,RED,EXP,CHM,Y,Z0,Z1
N MAXNAME,MAXSIG,MAXREM,MAXRX,RXHDR,%,RXIEN,CHMFLG,SORT,CNT,STG,PASS1,RXSORT,CKCM
K @TMP@(0)
RXVAR ; SET GLOBAL RX VARIABLES
S (IDT,TOT)=0
S CFIGIEN=$$CFG^VENPCCU
S MAX=$P($G(^VEN(7.41,+$G(DEFEF),2)),U,4) I 'MAX S MAX=15 ; MAX # OF RXS ALLOWED (UP TO 60) ; PATCHED BY GIS/OIT 10/15/05 ; PCC+ 2.5 PATCH 1
S X=$G(^VEN(7.41,DEFEF,14))
S MAXRX=$P(X,U) I 'MAXRX S MAXRX=150 ; MAX LENGTH OF COMPLETE RX
S MAXNAME=$P(X,U,2) I 'MAXNAME S MAXNAME=30 ; MAX LENGTH OF DRUG NAME
S MAXSIG=$P(X,U,3) I 'MAXSIG S MAXSIG=30 ; MAX LENGTH OF SIG
S MAXREM=$P(X,U,4) I 'MAXREM S MAXREM=49 ; MAX LENGTH OF REMARK
S RXSORT=+$P($G(^VEN(7.41,DEFEF,14)),U,5) ; SHOULD THE Rx LIST BE SORTED?
S RXHDR="PRESCRIPTIONS" ; DYNAMIC RX HEADER FLAG
S CKCM=0,X=$P($G(^VEN(7.41,DEFEF,2)),U,7)
I X S CKCM=1 ; FORM-SPECIFIC CHRONIC MED FILTER IS ACTIVE
I $P($G(^VEN(7.41,DEFEF,2)),U,7)="",$P($G(^VEN(7.5,CFIGIEN,0)),U,16),X'=0 S CKCM=1 ; GLOBAL CHRONIC MED FLAG ; PATCHED BY GIS/OIT 6/5/05 ; PCC+ 2.5 PATCH 5
I CKCM S RXHDR=RXHDR_" (Chronic meds only)",RXSORT=0 ; NO SORTING NECESSARY
I $P(X,U,8) S RXHDR="ACTIVE "_RXHDR
I $G(HDR25) S @TMP@(1,"mh")=RXHDR
MLOOP K STOP F Q:$G(STOP) S IDT=$O(^AUPNVMED("AA",DFN,IDT)) Q:'IDT S MIEN=0 F Q:$G(STOP) S MIEN=$O(^AUPNVMED("AA",DFN,IDT,MIEN)) Q:'MIEN D ; PATCHED 2/12/07 BY GIS FOR PCC+2.6
. S X=$G(^AUPNVMED(MIEN,0)),RIEN=+X,NTRX=$P(X,U,4)
. I $P($G(^VEN(7.41,+$G(DEFEF),2)),U,9),$D(@TMP@(0,RIEN)) Q ; REDUNDANT MED CHECKS
. S DCD=$P(X,U,8) I DCD Q ; QUIT IF MED HAS BEEN DICONTINUED
. S VIEN=$P(X,U,3),SIG=$P(X,U,5),QTY=$P(X,U,6),DAYS=$P(X,U,7),REM=""
. S %=$G(^AUPNVSIT(+VIEN,0)) I '$L(%) Q
. S DATE=$P(%,U) I 'DATE Q
. S SCAT=$P(%,U,7)
. S MED=$P($G(^PSDRUG(+RIEN,0)),U)
. I $L(NTRX) S MED=NTRX ; NON-TABLE NAME OF DRUG
. I '$L(MED) Q
. I SCAT="E" S MED=MED_" (ORx)" ; OUTSIDE RX
. I DATE,$L(MED) S Y=DATE\1 X ^DD("DD") S EXT=Y
. I '$L($G(EXT)) Q ; EXT DATE MUST EXIST
. ; AT THIS POINT EXT,MED,QTY,SIG AND REM HAVE BEEN SET
. I DAYS S PER=75,%=$P($G(^VEN(7.41,+$G(DEFEF),2)),U,6) S:% PER=% S X1=DT,X2=DATE\1 D ^%DTC I X>(DAYS+PER) Q ; ELIMINATE EXPIRED MEDS
. I 'DAYS S X1=DT,X2=-180 D C^%DTC I X>DATE Q ; IF DAYS ARE NOT SPECIFIED, DONT SHOW RX IF OVER 180 DAYS OLD
. I $P($G(^VEN(7.5,CFIGIEN,0)),U,19),$L($T(SIG^PSOHELP)) S SIG=$$SIG(SIG) I 1 ; EXPANDED SIG
. E I $D(^DD(52,10,9.2)) S X=SIG X ^DD(52,10,9.2) I $G(SIG)="" S SIG=X ; BKWRD COMPAT
. S CHMFLG=0 ; SETS CHRONIC MED STATUS TO DEFAULT VALUE OF "0"
RXCK . S RXIEN=+$O(^PSRX("APCC",MIEN,0)) ; CHECKS TO SEE IF RX FILE IS POPULATED
. I 'RXIEN G ADD ; IF RX FILE NOT POPULATED, BYPASS SPECIAL STUFF AND ADD RX TO THE ARRAY
. ; PATCHED BY GIS/OIT 03/15/06 ; PCC+ 2.5 PATCH 4
. I $P($G(^VEN(7.41,+$G(DEFEF),2)),U,8),$P($G(^PSRX(RXIEN,"STA")),U)>2 Q ; FAILED ACTIVE MED FILTER, SO QUIT
. I $D(^PS(55,DFN,"P","CP",RXIEN)) S CHMFLG=1 G NEWREM ; ALREADY A CRONIC MED - NO CHECK NEEDED
. I CKCM Q ; NOT A CHRONIC MED. FAILED CHRONIC MED FILTER, SO QUIT
NEWREM . S REM=$$REM(RXIEN) ; GET REMARKS
. S SIG=$$REFILL(SIG,RXIEN) ; ADD REFILL INFO TO SIG
ADD . ; ADD RX INFO TO ARRAY
. S TOT=TOT+1
. S @TMP@(0,RIEN)=""
. I 'RXSORT S CHMFLG=0 ; IF NOT SORTING, LUMP EVERYTHING TOGETHER UNDER THE "0" NODE
MAXMSG . I TOT>MAX S STOP=1,PASS1(0,TOT)="More meds on Health Summary!" Q ; WARNING MSG THAT NOT ALL MEDS WILL BE DISPLAYED
SORT . S PASS1(CHMFLG,TOT)=$G(EXT)_"|"_$G(MED)_"|"_$G(QTY)_"|"_$G(SIG)_"|"_$G(REM)
. Q
RXLIST ; FINAL PASS: CREATE THE (SORTED) MAIL MERGE NODES
I RXSORT D ; SORT HEADERS
. I '$D(PASS1(1)),'$D(PASS1(0)) S PASS1(1,.5)=" NO CURRENT MEDICATIONS" Q
. S PASS1(1,.5)=$S($D(PASS1(1)):"",1:"NO")_" CHRONIC MEDICATIONS"
. S PASS1(1,999999)=$S($D(PASS1(0)):"",1:"NO")_" INCIDENTAL MEDICATIONS" ; SORT SUB-HEADERS
. Q
S TOT=0
F SORT=1,0 S CNT=0 F S CNT=$O(PASS1(SORT,CNT)) Q:'CNT D
. S STG=$G(PASS1(SORT,CNT)) I '$L(STG) Q
. S TOT=TOT+1
. S MED=$P(STG,"|",2) S QTY=$P(STG,"|",3) S SIG=$P(STG,"|",4) S REM=$P(STG,"|",5)
. S EXT=$P(STG,"|",1) I STG'["|" S EXT=""
. I $P($G(^VEN(7.41,+$G(DEFEF),0)),U,11) D CLASSIC Q ; FORMAT AS A CLASSIC MED LIST
REVLIST . ; REVISED MED LIST USED IN VER 2 AND LATER
. I STG'["|" S %=STG
. E S %=EXT_" "_$E(MED,1,MAXNAME)_" "_$S(QTY:"#",1:"")_QTY_" "_$E(SIG,1,MAXSIG)_" "_$E(REM,1,MAXREM)
. S @TMP@(1,("md"_TOT))=% ; NEW Rx LIST FORMATTING: STORE ENTIRE Rx IN md NODE
. S @TMP@(1,("mm"_TOT))="",@TMP@(1,("mq"_TOT))="",@TMP@(1,("ms"_TOT))="",@TMP@(1,("mr"_TOT))=""
. Q
K @TMP@(0)
Q
;
CLASSIC ; EP-LEGACY Rx LIST FORMATTING
I STG'["|" S SIG=STG
S @TMP@(1,("md"_TOT))=EXT
S @TMP@(1,("mm"_TOT))=$E(MED,1,MAXNAME)
S @TMP@(1,("mq"_TOT))=$S(QTY:"#",1:"")_QTY
S @TMP@(1,("ms"_TOT))=$E(SIG,1,MAXSIG)
S @TMP@(1,("mr"_TOT))=$E(REM,1,MAXREM)
Q
;
SIG(SIG) ; EP-GET EXPANDED SIG
N X,INS1
I $G(SIG)="" Q ""
S X=SIG
D SIG^PSOHELP
I $L($G(INS1))'>1 S INS1=SIG
Q $G(INS1)
;
REFILL(SIG,RXIEN) ; EP-APPEND REFILL INFO TO SIG
N REF,X
S REF=$P($G(^PSRX(RXIEN,0)),U,9) I '$L(REF) Q SIG
S X=0 F S X=$O(^PSRX(RXIEN,1,X)) Q:'X S REF=REF-1 ; COMPUTE REMAINING REFILS BASED ON RX DATA
S SIG=SIG_" ("_REF_" refill"_$S(REF=1:"",1:"s")_" left)" ; APPEND THE SIG
Q SIG
;
REM(RXIEN) ; EP-GET INFO FROM PRESCRIPTION FILE: REMARKS, ISSUE DATE AND PRESCRIBING PROVIDER
N REM,RXP,X,TXT,MODE,ISDT,Y,DFLG
S REM=""
I '$P($G(^VEN(7.41,DEFEF,0)),U,12) S REM=$P($G(^PSRX(RXIEN,3)),U,7) ; GET REMINDER NOTE
S DFLG=$P($G(^VEN(7.41,DEFEF,2)),U,11) I DFLG D ; ISSUE DATE REQUESTED
. S %=$P($G(^PSRX(RXIEN,0)),U,13) I '% Q
. S ISDT=$$FMTE^XLFDT(%,2)
. I DFLG=1 S EXT=$G(EXT)_" (Issued: "_ISDT_")" Q ; APPEND ISSUE DATE
. S EXT="Issued: "_ISDT
. Q
I $P($G(^VEN(7.41,DEFEF,14)),U,9),$P($G(^PSRX(RXIEN,"STA")),U)>2 S REM=REM_" - "_$$GET1^DIQ(52,(RXIEN_","),100)
S MODE=$P($G(^VEN(7.41,DEFEF,0)),U,14) I 'MODE Q $E(REM,1,MAXREM) ; PROVIDER INFO NOT REQUESTED, SO QUIT NOW
S RXP=$P($G(^PSRX(+$G(RXIEN),0)),U,4) I 'RXP Q ""
S RXP=$$PRV^VENPCCU(RXP) I 'RXP Q "" ; COVERT FILE 6 IEN TO FILE 200 IEN IF NECESSARY
S X=$G(^VA(200,+RXP,0)) I '$L(X) Q ""
S TXT=$S(MODE=1:$P(X,U,2),1:$P(X,U)) ; CHOOSE BETWEEN INITIALS AND THE FULL NAME
I '$L(TXT),MODE=1,$L($P(X,U)) S TXT=$E($P(X,",",2))_$E(X) ; CREATE INITIALS ON THE FLY
I $L(TXT) S TXT=" ["_TXT_"]"
S REM=$E(REM,1,(MAXREM-3)-$L(TXT))_TXT
Q REM
;
CLASS(DFN) ; EP-GIVEN A DFN, RETURN THE PATIENT CLASS FOR USER PREFERENCES
N AGE,SEX,DOB,X,Y
S X=$P($G(^DPT(DFN,0)),U,2,3),DOB=$P(X,U,2),SEX=$P(X,U)
I DOB,$L(SEX)
E Q ""
S AGE=(DT-DOB)\10000
I AGE<2 Q 1
I AGE<12 Q 2
S Y=(SEX="F")
I AGE<18 Q (3+Y)
I AGE<65 Q (5+Y)
Q (7+Y)
;
VENPCC1H ; IHS/OIT/GIS - MORE ENCOUNTER FORM DATA MINING ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ; PATCHED BY GIS 12/9/04 TO ADD RX PROVIDER. CLEANED UP RX CODE
+3 ;
+4 ; PROCESS PROBLEMS AND MED FOR VER 2.5
+5 ;
DX(PRV,DFN) ; EP-GET PREFERRED DIAGNOSES
+1 NEW DIEN,GENERIC,ICD,IIEN,NAME,PTYPE,TOT,VAR,VAR1,X,%,INDX
+2 SET PTYPE=$$CLASS(DFN)
IF PTYPE=""
SET STOP=1
QUIT
+3 SET INDX=PRV_"."_PTYPE
+4 IF '$DATA(^VEN(7.1,"AG",INDX))
SET INDX=$$CP^VENPCCU(+$GET(DEPTIEN))_"."_PTYPE
+5 IF '$DATA(^VEN(7.1,"AG",INDX))
SET INDX=$$GP^VENPCCU_"."_PTYPE
+6 SET DIEN=0
FOR TOT=1:1:60
SET DIEN=$ORDER(^VEN(7.1,"AG",INDX,DIEN))
IF 'DIEN
QUIT
Begin DoDot:1
+7 SET X=$GET(^VEN(7.1,DIEN,0))
SET ICD=$PIECE(X,U,2)
SET NAME=$PIECE(X,U,3)
IF '$LENGTH(NAME)
QUIT
+8 SET NAME=$TRANSLATE(NAME,$CHAR(34),"")
SET NAME=$EXTRACT(NAME,1,27)
+9 SET VAR="d"_TOT
SET VAR1=VAR_"c"
+10 SET @TMP@(1,VAR)=NAME
SET @TMP@(1,VAR1)=ICD
+11 QUIT
End DoDot:1
+12 KILL @TMP@(0)
+13 QUIT
+14 ;
PROB(DFN) ; EP-GET ACTIVE PROBLEMS
+1 ; ALTERNATE PROBLEM LOOKUP
IF $GET(DEFEF)
IF $GET(DEPTIEN)
IF $PIECE($GET(^VEN(7.41,DEFEF,5)),U,17)
IF $LENGTH($TEXT(PROB^VENPCC1K))
DO PROB^VENPCC1K(DFN,DEPTIEN)
QUIT
+2 NEW %,ICD,ICD9,IIEN,NARR,NIEN,PIEN,STAT,STOP,TOT,TYPE,VAR,VAR1,X,FVFLAG,MAXNARR,MAX
+3 SET TOT=0
SET PIEN=999999999
SET MAXNARR=$$MAXNARR^VENPCCU(+$GET(DEFEF))
+4 ; MAX # PROBS DISPLAYED ; PATCHED BY GIS/OIT 10/15/05 ; PCC+ 2.5 PATCH 1
SET MAX=$PIECE($GET(^VEN(7.41,DEFEF,1)),U)
IF 'MAX
SET MAX=20
+5 FOR
SET PIEN=$ORDER(^AUPNPROB("AC",DFN,PIEN),-1)
IF 'PIEN
QUIT
Begin DoDot:1
+6 SET X=$GET(^AUPNPROB(PIEN,0))
SET NIEN=$PIECE(X,U,5)
SET IIEN=+X
SET STAT=$PIECE(X,U,12)
SET TYPE=$PIECE(X,4,U)
+7 IF NIEN
IF IIEN
IF STAT="A"
IF TYPE=""
+8 IF '$TEST
QUIT
+9 ; MARK THE ICD
SET NARR=$GET(^AUTNPOV(NIEN,0))
SET ICD=$PIECE($GET(^ICD9(IIEN,0)),U)
SET ICD9(IIEN)=""
+10 ; DATE OF ONSET REQUESTED
SET %=""
IF $PIECE($GET(^VEN(7.41,DEFEF,2)),U,12)
SET %=$PIECE($GET(^AUPNPROB(PIEN,0)),U,13)
+11 ; APPEND DATE OF ONSET
IF %
SET NARR=NARR_" (Onset: "_$$FMTE^XLFDT(%,"1D")_")"
+12 SET TOT=TOT+1
IF TOT=MAX
SET STOP=1
+13 SET VAR="p"_TOT
SET VAR1=VAR_"c"
+14 SET @TMP@(1,VAR)=$EXTRACT(NARR,1,MAXNARR)
SET @TMP@(1,VAR1)=ICD
+15 QUIT
End DoDot:1
IF $GET(STOP)
QUIT
+16 ; OPTION TO DISPLAY ONLY PROBLEMS - NO POVS
IF $PIECE($GET(^VEN(7.41,DEFEF,2)),U,13)
QUIT
POV ; ADD POVS TO THE LIST
+1 IF TOT>(MAX-3)
QUIT
+2 SET TOT=TOT+1
SET %=""
SET $PIECE(%,"-",15)=""
SET %=%_"POVs"_%
+3 ; INSERT THE POV DIVIDER LINE
SET @TMP@(1,("p"_TOT))=$EXTRACT(%,1,40)
SET @TMP@(1,"p"_TOT_"c")=$EXTRACT(%,1,8)
+4 ; GET MOST RECENT POVS UP TO MAX #
FOR
SET PIEN=$ORDER(^AUPNVPOV("AC",DFN,PIEN),-1)
IF 'PIEN
QUIT
Begin DoDot:1
+5 SET X=$GET(^AUPNVPOV(PIEN,0))
SET NIEN=$PIECE(X,U,4)
SET IIEN=+X
+6 ; DONT ADD POV IF ITS ALREADY IN THE LIST!
IF $DATA(ICD9(IIEN))
QUIT
+7 SET ICD9(IIEN)=""
+8 SET NARR=$GET(^AUTNPOV(+$GET(NIEN),0))
+9 ; GET ICD CODE OR BLOCK ICD CODE OF A "FOREIGN" VISIT
SET ICD=$$FVICD^VENPCCU(PIEN)
+10 IF '$LENGTH(NARR)
SET NARR=$PIECE($GET(^ICD9(IIEN,0)),U,3)
IF '$LENGTH(NARR)
SET NARR="<missing narrative>"
+11 SET TOT=TOT+1
IF TOT=MAX
SET STOP=1
+12 SET VAR="p"_TOT
SET VAR1=VAR_"c"
+13 SET @TMP@(1,VAR)=$EXTRACT(NARR,1,MAXNARR)
SET @TMP@(1,VAR1)=ICD
+14 QUIT
End DoDot:1
IF $GET(STOP)
QUIT
+15 ; CHECK TO SEE IF EXTENDED HEADER FILE IS IN USE
IF '$GET(HDR25)
QUIT
+16 ; GET 30 MOST RECENT POVS
DO POV^VENPCC1K(DFN)
+17 ; GET 30 MOST RECENT CLINIC-SPECIFIC POVS
DO CSPOV^VENPCC1K(DFN,DEPTIEN)
+18 ; GER 15 MOST RECENT MENTAL HEALTH POVS
DO MH^VENPCC1K(DFN)
+19 QUIT
+20 ;
MED(PRV,DFN) ; EP-GET RECENT MEDS
+1 NEW DATE,DAYS,DCD,EXT,MED,MIEN,QTY,RIEN,SIG,STOP,TOT,VAR,VIEN,SCAT,NTRX
+2 NEW X,X1,X2,REM,IDT,MAX,PER,STAT,REF,RED,EXP,CHM,Y,Z0,Z1
+3 NEW MAXNAME,MAXSIG,MAXREM,MAXRX,RXHDR,%,RXIEN,CHMFLG,SORT,CNT,STG,PASS1,RXSORT,CKCM
+4 KILL @TMP@(0)
RXVAR ; SET GLOBAL RX VARIABLES
+1 SET (IDT,TOT)=0
+2 SET CFIGIEN=$$CFG^VENPCCU
+3 ; MAX # OF RXS ALLOWED (UP TO 60) ; PATCHED BY GIS/OIT 10/15/05 ; PCC+ 2.5 PATCH 1
SET MAX=$PIECE($GET(^VEN(7.41,+$GET(DEFEF),2)),U,4)
IF 'MAX
SET MAX=15
+4 SET X=$GET(^VEN(7.41,DEFEF,14))
+5 ; MAX LENGTH OF COMPLETE RX
SET MAXRX=$PIECE(X,U)
IF 'MAXRX
SET MAXRX=150
+6 ; MAX LENGTH OF DRUG NAME
SET MAXNAME=$PIECE(X,U,2)
IF 'MAXNAME
SET MAXNAME=30
+7 ; MAX LENGTH OF SIG
SET MAXSIG=$PIECE(X,U,3)
IF 'MAXSIG
SET MAXSIG=30
+8 ; MAX LENGTH OF REMARK
SET MAXREM=$PIECE(X,U,4)
IF 'MAXREM
SET MAXREM=49
+9 ; SHOULD THE Rx LIST BE SORTED?
SET RXSORT=+$PIECE($GET(^VEN(7.41,DEFEF,14)),U,5)
+10 ; DYNAMIC RX HEADER FLAG
SET RXHDR="PRESCRIPTIONS"
+11 SET CKCM=0
SET X=$PIECE($GET(^VEN(7.41,DEFEF,2)),U,7)
+12 ; FORM-SPECIFIC CHRONIC MED FILTER IS ACTIVE
IF X
SET CKCM=1
+13 ; GLOBAL CHRONIC MED FLAG ; PATCHED BY GIS/OIT 6/5/05 ; PCC+ 2.5 PATCH 5
IF $PIECE($GET(^VEN(7.41,DEFEF,2)),U,7)=""
IF $PIECE($GET(^VEN(7.5,CFIGIEN,0)),U,16)
IF X'=0
SET CKCM=1
+14 ; NO SORTING NECESSARY
IF CKCM
SET RXHDR=RXHDR_" (Chronic meds only)"
SET RXSORT=0
+15 IF $PIECE(X,U,8)
SET RXHDR="ACTIVE "_RXHDR
+16 IF $GET(HDR25)
SET @TMP@(1,"mh")=RXHDR
MLOOP ; PATCHED 2/12/07 BY GIS FOR PCC+2.6
KILL STOP
FOR
IF $GET(STOP)
QUIT
SET IDT=$ORDER(^AUPNVMED("AA",DFN,IDT))
IF 'IDT
QUIT
SET MIEN=0
FOR
IF $GET(STOP)
QUIT
SET MIEN=$ORDER(^AUPNVMED("AA",DFN,IDT,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+1 SET X=$GET(^AUPNVMED(MIEN,0))
SET RIEN=+X
SET NTRX=$PIECE(X,U,4)
+2 ; REDUNDANT MED CHECKS
IF $PIECE($GET(^VEN(7.41,+$GET(DEFEF),2)),U,9)
IF $DATA(@TMP@(0,RIEN))
QUIT
+3 ; QUIT IF MED HAS BEEN DICONTINUED
SET DCD=$PIECE(X,U,8)
IF DCD
QUIT
+4 SET VIEN=$PIECE(X,U,3)
SET SIG=$PIECE(X,U,5)
SET QTY=$PIECE(X,U,6)
SET DAYS=$PIECE(X,U,7)
SET REM=""
+5 SET %=$GET(^AUPNVSIT(+VIEN,0))
IF '$LENGTH(%)
QUIT
+6 SET DATE=$PIECE(%,U)
IF 'DATE
QUIT
+7 SET SCAT=$PIECE(%,U,7)
+8 SET MED=$PIECE($GET(^PSDRUG(+RIEN,0)),U)
+9 ; NON-TABLE NAME OF DRUG
IF $LENGTH(NTRX)
SET MED=NTRX
+10 IF '$LENGTH(MED)
QUIT
+11 ; OUTSIDE RX
IF SCAT="E"
SET MED=MED_" (ORx)"
+12 IF DATE
IF $LENGTH(MED)
SET Y=DATE\1
XECUTE ^DD("DD")
SET EXT=Y
+13 ; EXT DATE MUST EXIST
IF '$LENGTH($GET(EXT))
QUIT
+14 ; AT THIS POINT EXT,MED,QTY,SIG AND REM HAVE BEEN SET
+15 ; ELIMINATE EXPIRED MEDS
IF DAYS
SET PER=75
SET %=$PIECE($GET(^VEN(7.41,+$GET(DEFEF),2)),U,6)
IF %
SET PER=%
SET X1=DT
SET X2=DATE\1
DO ^%DTC
IF X>(DAYS+PER)
QUIT
+16 ; IF DAYS ARE NOT SPECIFIED, DONT SHOW RX IF OVER 180 DAYS OLD
IF 'DAYS
SET X1=DT
SET X2=-180
DO C^%DTC
IF X>DATE
QUIT
+17 ; EXPANDED SIG
IF $PIECE($GET(^VEN(7.5,CFIGIEN,0)),U,19)
IF $LENGTH($TEXT(SIG^PSOHELP))
SET SIG=$$SIG(SIG)
IF 1
+18 ; BKWRD COMPAT
IF '$TEST
IF $DATA(^DD(52,10,9.2))
SET X=SIG
XECUTE ^DD(52,10,9.2)
IF $GET(SIG)=""
SET SIG=X
+19 ; SETS CHRONIC MED STATUS TO DEFAULT VALUE OF "0"
SET CHMFLG=0
RXCK ; CHECKS TO SEE IF RX FILE IS POPULATED
SET RXIEN=+$ORDER(^PSRX("APCC",MIEN,0))
+1 ; IF RX FILE NOT POPULATED, BYPASS SPECIAL STUFF AND ADD RX TO THE ARRAY
IF 'RXIEN
GOTO ADD
+2 ; PATCHED BY GIS/OIT 03/15/06 ; PCC+ 2.5 PATCH 4
+3 ; FAILED ACTIVE MED FILTER, SO QUIT
IF $PIECE($GET(^VEN(7.41,+$GET(DEFEF),2)),U,8)
IF $PIECE($GET(^PSRX(RXIEN,"STA")),U)>2
QUIT
+4 ; ALREADY A CRONIC MED - NO CHECK NEEDED
IF $DATA(^PS(55,DFN,"P","CP",RXIEN))
SET CHMFLG=1
GOTO NEWREM
+5 ; NOT A CHRONIC MED. FAILED CHRONIC MED FILTER, SO QUIT
IF CKCM
QUIT
NEWREM ; GET REMARKS
SET REM=$$REM(RXIEN)
+1 ; ADD REFILL INFO TO SIG
SET SIG=$$REFILL(SIG,RXIEN)
ADD ; ADD RX INFO TO ARRAY
+1 SET TOT=TOT+1
+2 SET @TMP@(0,RIEN)=""
+3 ; IF NOT SORTING, LUMP EVERYTHING TOGETHER UNDER THE "0" NODE
IF 'RXSORT
SET CHMFLG=0
MAXMSG ; WARNING MSG THAT NOT ALL MEDS WILL BE DISPLAYED
IF TOT>MAX
SET STOP=1
SET PASS1(0,TOT)="More meds on Health Summary!"
QUIT
SORT SET PASS1(CHMFLG,TOT)=$GET(EXT)_"|"_$GET(MED)_"|"_$GET(QTY)_"|"_$GET(SIG)_"|"_$GET(REM)
+1 QUIT
End DoDot:1
RXLIST ; FINAL PASS: CREATE THE (SORTED) MAIL MERGE NODES
+1 ; SORT HEADERS
IF RXSORT
Begin DoDot:1
+2 IF '$DATA(PASS1(1))
IF '$DATA(PASS1(0))
SET PASS1(1,.5)=" NO CURRENT MEDICATIONS"
QUIT
+3 SET PASS1(1,.5)=$SELECT($DATA(PASS1(1)):"",1:"NO")_" CHRONIC MEDICATIONS"
+4 ; SORT SUB-HEADERS
SET PASS1(1,999999)=$SELECT($DATA(PASS1(0)):"",1:"NO")_" INCIDENTAL MEDICATIONS"
+5 QUIT
End DoDot:1
+6 SET TOT=0
+7 FOR SORT=1,0
SET CNT=0
FOR
SET CNT=$ORDER(PASS1(SORT,CNT))
IF 'CNT
QUIT
Begin DoDot:1
+8 SET STG=$GET(PASS1(SORT,CNT))
IF '$LENGTH(STG)
QUIT
+9 SET TOT=TOT+1
+10 SET MED=$PIECE(STG,"|",2)
SET QTY=$PIECE(STG,"|",3)
SET SIG=$PIECE(STG,"|",4)
SET REM=$PIECE(STG,"|",5)
+11 SET EXT=$PIECE(STG,"|",1)
IF STG'["|"
SET EXT=""
+12 ; FORMAT AS A CLASSIC MED LIST
IF $PIECE($GET(^VEN(7.41,+$GET(DEFEF),0)),U,11)
DO CLASSIC
QUIT
REVLIST ; REVISED MED LIST USED IN VER 2 AND LATER
+1 IF STG'["|"
SET %=STG
+2 IF '$TEST
SET %=EXT_" "_$EXTRACT(MED,1,MAXNAME)_" "_$SELECT(QTY:"#",1:"")_QTY_" "_$EXTRACT(SIG,1,MAXSIG)_" "_$EXTRACT(REM,1,MAXREM)
+3 ; NEW Rx LIST FORMATTING: STORE ENTIRE Rx IN md NODE
SET @TMP@(1,("md"_TOT))=%
+4 SET @TMP@(1,("mm"_TOT))=""
SET @TMP@(1,("mq"_TOT))=""
SET @TMP@(1,("ms"_TOT))=""
SET @TMP@(1,("mr"_TOT))=""
+5 QUIT
End DoDot:1
+6 KILL @TMP@(0)
+7 QUIT
+8 ;
CLASSIC ; EP-LEGACY Rx LIST FORMATTING
+1 IF STG'["|"
SET SIG=STG
+2 SET @TMP@(1,("md"_TOT))=EXT
+3 SET @TMP@(1,("mm"_TOT))=$EXTRACT(MED,1,MAXNAME)
+4 SET @TMP@(1,("mq"_TOT))=$SELECT(QTY:"#",1:"")_QTY
+5 SET @TMP@(1,("ms"_TOT))=$EXTRACT(SIG,1,MAXSIG)
+6 SET @TMP@(1,("mr"_TOT))=$EXTRACT(REM,1,MAXREM)
+7 QUIT
+8 ;
SIG(SIG) ; EP-GET EXPANDED SIG
+1 NEW X,INS1
+2 IF $GET(SIG)=""
QUIT ""
+3 SET X=SIG
+4 DO SIG^PSOHELP
+5 IF $LENGTH($GET(INS1))'>1
SET INS1=SIG
+6 QUIT $GET(INS1)
+7 ;
REFILL(SIG,RXIEN) ; EP-APPEND REFILL INFO TO SIG
+1 NEW REF,X
+2 SET REF=$PIECE($GET(^PSRX(RXIEN,0)),U,9)
IF '$LENGTH(REF)
QUIT SIG
+3 ; COMPUTE REMAINING REFILS BASED ON RX DATA
SET X=0
FOR
SET X=$ORDER(^PSRX(RXIEN,1,X))
IF 'X
QUIT
SET REF=REF-1
+4 ; APPEND THE SIG
SET SIG=SIG_" ("_REF_" refill"_$SELECT(REF=1:"",1:"s")_" left)"
+5 QUIT SIG
+6 ;
REM(RXIEN) ; EP-GET INFO FROM PRESCRIPTION FILE: REMARKS, ISSUE DATE AND PRESCRIBING PROVIDER
+1 NEW REM,RXP,X,TXT,MODE,ISDT,Y,DFLG
+2 SET REM=""
+3 ; GET REMINDER NOTE
IF '$PIECE($GET(^VEN(7.41,DEFEF,0)),U,12)
SET REM=$PIECE($GET(^PSRX(RXIEN,3)),U,7)
+4 ; ISSUE DATE REQUESTED
SET DFLG=$PIECE($GET(^VEN(7.41,DEFEF,2)),U,11)
IF DFLG
Begin DoDot:1
+5 SET %=$PIECE($GET(^PSRX(RXIEN,0)),U,13)
IF '%
QUIT
+6 SET ISDT=$$FMTE^XLFDT(%,2)
+7 ; APPEND ISSUE DATE
IF DFLG=1
SET EXT=$GET(EXT)_" (Issued: "_ISDT_")"
QUIT
+8 SET EXT="Issued: "_ISDT
+9 QUIT
End DoDot:1
+10 IF $PIECE($GET(^VEN(7.41,DEFEF,14)),U,9)
IF $PIECE($GET(^PSRX(RXIEN,"STA")),U)>2
SET REM=REM_" - "_$$GET1^DIQ(52,(RXIEN_","),100)
+11 ; PROVIDER INFO NOT REQUESTED, SO QUIT NOW
SET MODE=$PIECE($GET(^VEN(7.41,DEFEF,0)),U,14)
IF 'MODE
QUIT $EXTRACT(REM,1,MAXREM)
+12 SET RXP=$PIECE($GET(^PSRX(+$GET(RXIEN),0)),U,4)
IF 'RXP
QUIT ""
+13 ; COVERT FILE 6 IEN TO FILE 200 IEN IF NECESSARY
SET RXP=$$PRV^VENPCCU(RXP)
IF 'RXP
QUIT ""
+14 SET X=$GET(^VA(200,+RXP,0))
IF '$LENGTH(X)
QUIT ""
+15 ; CHOOSE BETWEEN INITIALS AND THE FULL NAME
SET TXT=$SELECT(MODE=1:$PIECE(X,U,2),1:$PIECE(X,U))
+16 ; CREATE INITIALS ON THE FLY
IF '$LENGTH(TXT)
IF MODE=1
IF $LENGTH($PIECE(X,U))
SET TXT=$EXTRACT($PIECE(X,",",2))_$EXTRACT(X)
+17 IF $LENGTH(TXT)
SET TXT=" ["_TXT_"]"
+18 SET REM=$EXTRACT(REM,1,(MAXREM-3)-$LENGTH(TXT))_TXT
+19 QUIT REM
+20 ;
CLASS(DFN) ; EP-GIVEN A DFN, RETURN THE PATIENT CLASS FOR USER PREFERENCES
+1 NEW AGE,SEX,DOB,X,Y
+2 SET X=$PIECE($GET(^DPT(DFN,0)),U,2,3)
SET DOB=$PIECE(X,U,2)
SET SEX=$PIECE(X,U)
+3 IF DOB
IF $LENGTH(SEX)
+4 IF '$TEST
QUIT ""
+5 SET AGE=(DT-DOB)\10000
+6 IF AGE<2
QUIT 1
+7 IF AGE<12
QUIT 2
+8 SET Y=(SEX="F")
+9 IF AGE<18
QUIT (3+Y)
+10 IF AGE<65
QUIT (5+Y)
+11 QUIT (7+Y)
+12 ;
