VENPCC1H.m

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)