VENPCCMD.m

VENPCCMD ; IHS/OIT/GIS - USER PREFERENCE MANAGER FOR DIAGNOSES AND ICD CODES ;

 ;;2.6;PCC+;;NOV 12, 2007

 ;

 ;

 ; 

NEW N EF,PRV,PGRP,LIST,STATUS,X,Y,%,TITLE,DTOUT,DUOUT,DIRUT,%Y,IGRP,NFLG

 I '$D(LOOP) N LOOP S LOOP=""

INIT S (PRV,EF)="",PGRP=0,NFLG=0

 I $D(^VEN(7.34,"AC")),$L($T(DX^VENPCC1P)) S NFLG=1 ; NEW PREFERENCE LIST IS IN USE  ; PATCHED BY GIS/OIT 5/26/06 ; PCC+ 2.5 PATCH 5

RUN W:$D(IOF) @IOF W !!!?20,"*****  USER PREFERENCE MANAGER FOR DIAGNOSES  *****"

 W !!!

LOOP I LOOP S %=$$NEXT(EF,PRV,PGRP) Q:'%  W !!! S EF=$P(%,";"),PRV=$P(%,";",2),PGRP=$P(%,";",3) G LST

LEF S EF=$$EF(EF)

 I EF="",'$G(NFLG) Q

 I EF=U Q

LPRV S PRV=$$PRV(PRV) I PRV="" Q

LGRP S PGRP=$$PGRP() I PGRP="" Q

ITEMGRP ; GET THE ITEM GROUP

 I '$G(NFLG) G LST

 S IGRP=$P($G(^VEN(7.41,+$G(EF),0)),U,18)

 I 'IGRP S IGRP=$$IGRP(IGRP) I 'IGRP Q

LST I '$G(NFLG) S LIST=$$LIST(+EF,+PRV,+PGRP) I 1 ; LIST BASED ON 19707.1

 E  S LIST=$$NLIST(+IGRP,+PRV,+PGRP) ; LIST BASED ON 19707.34

 S TITLE=$$TITLE(EF,PRV,PGRP)

EDIT S STATUS=$$STATUS(+EF,LIST) W !!,$P(STATUS,U,3)

 W !,TITLE

 W ! D SHOW(LIST)

 I $L(LIST) W !!,"Select from 'ADD', 'EDIT', 'DELETE', 'COPY', 'SUBMIT', 'NEXT LIST', 'QUIT'" S DIR(0)="SBO^A:ADD;E:EDIT;D:DELETE;C:COPY;S:SUBMIT;N:NEXT LIST;Q:QUIT"

 I '$L(LIST) W !!,"Select from 'ADD', 'COPY', 'NEXT LIST', 'QUIT'" S DIR(0)="SBO^A:ADD;C:COPY;N:NEXT LIST;Q:QUIT"

 S DIR("A")="Your choice" KILL DA D ^DIR KILL DIR

 I Y=U!($D(DTOUT)) Q

 I LOOP,Y="" G LOOP

 I Y="A" S LIST=$$ADD(LIST,STATUS) G EDIT

 I Y="D" S LIST=$$DEL(LIST,STATUS) G EDIT

 I Y="C" S LIST=$$COPY(LIST,STATUS,TITLE,EF,PRV) G EDIT

 I Y="E" S LIST=$$UPDATE(LIST,STATUS) G EDIT

 I Y="S" G RUN:$$SUBMIT(LIST,EF,PRV,PGRP),EDIT

 I Y="N" G LPRV

 Q

 ; 

IGRP(IGRP) ; EP - RETURN THE ICD GROUP

 N DIC,X,Y,%

 S DIC="^VEN(7.33,",DIC(0)="AEQ"

 S DIC("A")="ICD Preference group: "

 I $G(IGRP) S DIC("B")=$P($G(^VEN(7.33,IGRP,0)),U)

 E  S DIC("B")="PRIMARY"

 D ^DIC I Y=-1 Q ""

 Q Y

 ; 

EF(EF) ; EP - LOOKUP EF

 N DIC,X,Y,%

 S DIC="^VEN(7.41,",DIC(0)="AEQ"

 S DIC("A")="Encounter form name: "

 I $G(NFLG) S DIC("A")="Encounter form name (optional): "

 I $L($G(EF)) S DIC("B")=$P(EF,U,2)

 D ^DIC I X?1."^" Q U

 I Y=-1 Q ""

 Q Y

 ; 

PRV(PRV) ; EP - LOOKUP PROVIDER

 N DIC,X,Y,%

 S DIC="^VA(200,",DIC(0)="AEQ"

 S DIC("A")="Provider: "

 I $L($G(PRV)) S DIC("B")=$P(PRV,U,2)

 D ^DIC I Y=-1 Q ""

 Q Y

 ; 

PGRP(DFLT) ; EP - RETURN THE PATIENT GROUP

 N DIC,X,Y,%

 N DIR,DTOUT,DIRUT,DUOUT

 S DIR(0)="S^1:Infants;2:Children;3:Teen Males;4:Teen Females;5:Adult Males;6:Adult Females;7:Senior Males;8:Senior Females"

 I $G(DFLT),DFLT>0,DFLT<9 S %=$P(DIR(0),(DFLT_":"),2) S %=$P(%,";") Q DFLT_U_%

 S DIR("A")="Patient group" KILL DA D ^DIR KILL DIR

 I 'Y Q ""

 Q Y_U_Y(0)

 ; 

STATUS(EF,X) ; EP - SHOW MAX ENTRIES POSSIBLE

 N DISP,MAX

 S DISP=$L(X,U)

 I X="" S DISP=0

 S MAX=+$P($G(^VEN(7.41,+EF,1)),U,2)

 S X="There is room for "_MAX_" entries on this form" I DISP S X=X_" and you have selected "_DISP_$S(DISP=1:" entry",1:" entries")

 I $G(NFLG),DISP S X="You have selected "_DISP_$S(DISP=1:" entry",1:" entries")_" so far"

 Q MAX_U_DISP_U_X

 ; 

TITLE(EF,PRV,G) ; EP - TITLE OF LIST

 N %

 S %=$P(PRV,U,2)_"/"_$P(PGRP,U,2)

 I $L($G(EF)) S %=%_"/"_$P(EF,U,2)_"/"

 Q %

 ; 

LIST(EF,PRV,PGRP) ; EP - CREATED THE ICD LIST

 I $G(NFLG) G NLIST ; USE NEW ICD PREF FILE

 N INDX,SIEN,REC,X,NAME,CODE,HDR

 S INDX=PRV_"."_PGRP,SIEN=0,REC=""

 F  S SIEN=$O(^VEN(7.1,"AG",INDX,SIEN)) Q:'SIEN  D

 . S X=$G(^VEN(7.1,SIEN,0)) I '$L(X) Q

 . S NAME=$P(X,U,3),CODE=$P(X,U,2)

 . I $L(REC) S REC=REC_U

 . S REC=REC_NAME_";"_CODE

 . Q

 Q REC

 ; 

NLIST(IGRP,PRV,PGRP) ; EP - RAW PREFERENCE LIST FOR A PROVIDER, ICD GROUP, AND PT GRP

 N SIEN,REC,X,NAME,CODE,HDR,ROOT,PCE,GRP

 S SIEN=0,REC=""

 S PCE=$P("1^3^7^5^11^9^15^13",U,PGRP)

 F  S SIEN=$O(^VEN(7.34,SIEN)) Q:'SIEN  D

 . S GRP=$P($G(^VEN(7.34,SIEN,1)),U,PCE) I 'GRP Q

 . S X=$G(^VEN(7.34,SIEN,0)) I '$L(X) Q

 . I +X'=PRV Q

 . I $P(X,U,2)'=IGRP Q

 . S NAME=$P(X,U,3) I '$L(NAME) Q

 . S CODE=$P(X,U,4) I '$L(CODE) Q

 . I $L(REC) S REC=REC_U

 . S REC=REC_NAME_";"_CODE

 . I $$ICD^VENPCCU(CODE) W !,CODE," IS AN INVALID ICD CODE!!!"

 . Q

 Q REC

 ; 

SHOW(X) ; EP-DISPLAY THE LIST

 N NAME,CODE,I,Y,STOP

 F I=1:1:$L(X,U) D  I $G(STOP) Q

 . S Y=$P(X,U,I)

 . I Y="" W:I=1 !,"No entries found!" Q

 . S NAME=$P(Y,";"),CODE=$P(Y,";",2) W !

 . I '(I#18) S STOP='$$WAIT^VENPCCU I STOP Q

 . W I,?5,NAME," ",CODE

 . Q

 Q

 ; 

ADD(LIST,STAT) ; EP-ADD AN ENTRY

 N DIRUT,DUOUT,DTOUT,X,Y,%,DIC,POS,NAME,CODE

ADD1 I $G(NFLG) W ! G POS

 S X=$P(STAT,U)-$P(STAT,U,2)

 I X>0 W !,"You have room for "_X_" more "_$S(X>1:"entries",1:"entry")

 E  W !,"You are over the limit for adding new entries!"

 W !

POS ; 

 I '$L(LIST) S POS=1 G NAME

 S DIR("A")="Insert new entry at what position? (1 - END of list)"

 S DIR(0)="F^1:3",DIR("B")="END" KILL DA D ^DIR KILL DIR S POS=Y

 I $D(DIRUT) K DIRUT,DTOUT,DUOUT,DIROUT Q LIST

P1 I POS=$E("END of list",1,$L(POS)) W $E("END of list",$L(POS)+1,99) S POS=1+$P(STAT,U,2) G NAME

 I POS,POS>0,POS'>$P(STAT,U,2)

 E  W "  ??" G POS

NAME ; 

 S DIR(0)="F^1:30",DIR("A")="Name of entry" KILL DA D ^DIR KILL DIR

 I '$D(DIRUT),'$D(DUOUT),'$D(DTOUT) S NAME=Y G CODE

 K DIRUT,DTOUT,DUOUT

 Q LIST

 ; 

CODE ; EP - GET ICD CODE

 S CODE="",DIR(0)="F^1:6",DIR("A")="ICD Code" KILL DA D ^DIR KILL DIR

 I $D(DUOUT)!($D(DTOUT)) Q LIST

 S CODE=Y

 S %=$$ICD^VENPCCU($G(CODE))

 I '% W !,"Invalid ICD code!!!  Try again...",!! G CODE

 W " (",$P($G(^ICD9(%,0)),U,3),")" ; CONFIRMATION

ENT ; 

 I $P(LIST,U,POS)="" S $P(LIST,U,POS)=NAME_";"_CODE

 E  S %=$P(LIST,U,POS) S $P(LIST,U,POS)=NAME_";"_CODE_U_%

 S %=$P(STAT,U,2)+1 S $P(STAT,U,2)=%

 W ! D SHOW(LIST) W !

 W !!,"Want to add another entry" S %=1

 D YN^DICN I %'=1 Q LIST

 G ADD1

 ; 

DEL(LIST,STAT) ;EP - DELETE AN ENTRY

 N DIRUT,DUOUT,DTOUT,X,Y,%,POS,ITEM,CNT,TOT

DEL1 S %=$P(STAT,U,2) I '% D  Q ""

 . W !,"There are no more entries to delete!"

 . I '$G(NFLG) D WIPE Q  ; KILL OF ALL ENTRIES IN THE ICD FILE

 . D NWIPE

 . Q

 I '$G(NFLG) S %=((+STAT)-($P(STAT,U,2))) I %<0 S %=%*-1 W !,"You should delete at least "_%_" entries..."

DEL2 S DIR(0)="FO^",DIR("A")="Delete entry from what position" K DA

 S (HELP,DIR("?"))="Enter a number, a range (e.g., '1-32'), or '*' (all)"

 D ^DIR K DIR

 I Y?1."^" Q LIST

 I Y=+Y,Y>0,Y=(Y\1) S POS=+Y G CKD

 I Y="*"!(Y="ALL")!(Y="all") S Y="*",POS=1,POS(1)=$P(STAT,U,2) G CKD

 I Y?1.3N1"-"1.3N S POS=+Y,POS(1)=$P(Y,"-",2)

 I '$G(POS) W !,HELP G DEL2

CKD I POS>$P(STAT,U,2)!(+$G(POS(1))>$P(STAT,U,2)) W !,"Select a number between 1 and ",$P(STAT,U,2) K POS G DEL2

 W !,"Sure you want to delete "_$S(Y=+Y:$P($P(LIST,U,POS),";"),Y["-":Y,1:"ALL")

 S %=1 D YN^DICN I $D(DIRUT)!($D(DTOUT)) Q LIST

 I %'=1 G DEL2

 I $G(POS(1)) S CNT=0,TOT=POS(1)-POS

DLOOP S ITEM=$TR($P(LIST,U,POS),";"," ")

 I POS=$P(STAT,U,2) S LIST=$P(LIST,U,1,POS-1) G DEL3

 I POS=1 S LIST=$P(LIST,U,2,99) G DEL3

 S LIST=$P(LIST,U,1,POS-1)_U_$P(LIST,U,POS+1,99)

DEL3 S %=$P(STAT,U,2)-1 S $P(STAT,U,2)=%

 W !,"  Deleting ",ITEM

 I $G(POS(1)) S CNT=CNT+1 I CNT'>TOT G DLOOP

 K ITEM,CNT,TOT,POS

 I '$L(LIST) G DEL1

 W !!,"Want to delete another entry" S %=1

 D YN^DICN I %'=1 Q LIST

 D SHOW(LIST)

 G DEL1

 ; 

WIPE ; EP - CLEAN OUT ALL 19707.1 ENTRIES FOR A PROVIDER AND PT GROUP

 N DA,DIK,IX

 I '$D(^VA(200,+$G(PRV),0)) Q

 I '$G(PGRP) Q

 S DIK="^VEN(7.1,",DA=0

 S IX=+PRV_"."_+PGRP

 F  S DA=$O(^VEN(7.1,"AG",IX,DA)) Q:'DA  D ^DIK

 D ^XBFMK

 Q

 ;

NWIPE ; EP - CLEAN OUT ALL 19707.34 FOR ENTRIES FOR A PROVIDER, ICD GROUP, AND PT GROUP

 N DA,DIK,IX,BASE,PCE

 I '$D(^VA(200,+$G(PRV),0)) Q

 I '$G(PGRP) Q

 I '$D(^VEN(7.33,+$G(IGRP),0)) Q

 S PCE=$P("1^3^7^5^11^9^15^13",U,PGRP)

 S DIK="^VEN(7.1,",DA=0

 S (IX,BASE)=+PRV_"_"_+IGRP

 F  S IX=$O(^VEN(7.34,"AC",IX)) Q:IX=""  Q:$P(IX,"_",1,2)'=BASE  D

 . S DA=0

 . F  S DA=$O(^VEN(7.34,"AC",IX,DA)) Q:'DA  D

 .. I '$D(^VEN(7.34,DA,1)) Q

 .. S $P(^VEN(7.34,DA,1),U,PCE)=""

 .. I ^VEN(7.34,DA,1)'[1 D ^DIK

 .. Q

 . Q

 D ^XBFMK

 Q

 ; 

COPY(LIST,STAT,TITLE,EF,PRV) ; EP-COPY IN ANOTHER LIST

 N PGRP,CTITLE,CLIST,DUOUT,DIRUT,DTOUT,I

 W !,"Enter name of provider to copy from =>"

 S PRV1=$$PRV I 'PRV1 Q LIST

 W !!,"Define the Patient Group to copy from =>"

 S PGRP=$$PGRP I PGRP="" Q LIST

 I '$G(NFLG) S CLIST=$$LIST(+EF,+PRV1,+PGRP) I 1 ; LIST BASED ON 19707.1

 E  S CLIST=$$NLIST(+IGRP,+PRV1,+PGRP) ; LIST BASED ON 19707.34

 I CLIST="" W !,"Unable to copy because no entries found!" H 3 Q LIST

 S CTITLE=$$TITLE(EF,PRV1,PGRP)

 W !,CTITLE

 W ! D SHOW(CLIST)

 W !,"OK to copy non-redundant entries from this list"

 S %=1 D YN^DICN I %'=1 Q LIST

 F I=1:1:$L(CLIST,U) S X=$P(CLIST,U,I) I LIST'[X S:LIST'="" LIST=LIST_U S LIST=LIST_X

 W !!,"Target list: ",TITLE

 Q LIST

 ; 

SUB(LIST,EF,PRV,PGRP) ; EP FOR SUBMITTING AN EXTERNALY GENERATED LIST

 N EFLAG S EFLAG=1

 G S1

 ; 

SUBMIT(LIST,EF,PRV,PGRP) ; EP-ENTER THE LIST

S1 N %,CODE,DIR,Y,DIRUT,DTOUT,DUOUT,EX

 I $G(EFLAG) S Y="A" G S2

 I '$G(NFLG) D  I EX>0 Q 0

 . S EX=$L(LIST,U)-(+$P($G(^VEN(7.41,+EF,1)),U,2))

 . I EX<1 Q

 . W !!,"You have exceeded the maximum number of items allowed!"

 . W !,"Delete ",EX," item",$S(EX>1:"s",1:"")," before proceeding",!

 . H 2

 . Q

 W !,"The following list will be saved: ",TITLE

 D SHOW(LIST)

 W !,"Are you sure everything is OK"

 S %=1 D YN^DICN I %'=1 Q 0

 S %=$P($P(LIST,U),";",2) S CODE=$L(%)

 I $G(NFLG) S Y="S" W "  <- SAVED!" G S2

 I CODE S DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;C:SORT BY CODE AND SAVE;S:SAVE AS IS"

 E  S DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;S:SAVE"

 S DIR("A")="Your choice" KILL DA D ^DIR KILL DIR

S2 I Y="A" S LIST=$$ALPH(LIST,1) D SAVE(LIST,EF,PRV,PGRP) Q 1

 I Y="C" S LIST=$$ALPH(LIST,2) D SAVE(LIST,EF,PRV,PGRP) Q 1

 I Y="S" D SAVE(LIST,EF,PRV,PGRP) Q 1

 Q 0

 ; 

ALPH(LIST,PCE) ; EP-ALPHABETIZE THE LIST

 N I,X,Y,Z

 F I=1:1:$L(LIST,U) S X=$P(LIST,U,I) I $L(X) D

 . S Y=$P(X,";",PCE)

 . S LIST(Y)=I

 . Q

 S I=0,Z=""

 S Y="" F  S Y=$O(LIST(Y)) Q:Y=""  D

 . S I=I+1

 . S $P(Z,U,I)=$P(LIST,U,LIST(Y))

 . Q

 Q Z

 ; 

SAVE(LIST,EF,PRV,PGRP) ; EP-DELETE THE OLD LIST AND SAVE THE NEW ONE

 I $G(NFLG) G NSAVE

 I $D(^VEN(7.41,+$G(EF),0)),$L(LIST),PGRP,PGRP=PGRP\1,PGRP>0,PGRP<9

 E  Q

 N CTAG,D,D0,DI,DIE,DIG,DIH,DIU,DIV,DQ,DR,HDR,PCE,DIK,DIC,IX,DA,MN,IX,CODE,DIW,HDR,DICR,%,%Y,DLAYGO

 S DIK="^VEN(7.1,"

 S IX=+PRV_"."_+PGRP

 S DA=0 F  S DA=$O(^VEN(7.1,"AG",IX,DA)) Q:'DA  D ^DIK

 S DIC=DIK,DIC(0)="L",DIE=DIC,DLAYGO=19707.1

 F PCE=1:1:$L(LIST,U) D

 . S %=$P(LIST,U,PCE)

 . S CODE=$P(%,";",2),NAME=$P(%,";")

 . S X="""`"_+PRV_""""

 . D ^DIC I Y=-1 Q

 . S DA=+Y,DR=".03////"_NAME_";.02////"_CODE_";.04////"_+PGRP

 . L +^VEN(7.1,DA):5 I  D ^DIE L -^VEN(7.1,DA)

 . Q

 Q

 ; 

NSAVE ; EP - SAVE TO NEW ICD FILE 19707.34

 I $L($G(LIST)),$G(PRV),$G(PGRP),$G(IGRP)

 E  Q

 N DIC,DIE,DA,DR,X,Y,NAME,CODE,DIK,IX,BASE,PCE,GPCE,FLD,TXT,IIEN,PRE

 S GPCE=$P("1^3^7^5^11^9^15^13",U,PGRP)

 S (DIC,DIE,DIK)="^VEN(7.34,",DIC(0)="L",DLAYGO=19707.34

 S (IX,BASE)=+PRV_"_"_+IGRP

 F  S IX=$O(^VEN(7.34,"AC",IX)) Q:IX=""  Q:$P(IX,"_",1,2)'=BASE  D  ; WIPE ALL EXISTING PRV/PGRP 19707.34 ENTRIES

 . S DA=0

 . F  S DA=$O(^VEN(7.34,"AC",IX,DA)) Q:'DA  D  ; IT IS POSSIBLE TO HAVE MULTIPLE ENTRIES FOR A SINGLE ICD CODE!

 .. I '$P($G(^VEN(7.34,DA,1)),U,GPCE) Q  ; THIS ENTRY IS NOT ASSOCIATED WITH THE CURRENT PT GROUP, SO QUIT

 .. S $P(^VEN(7.34,DA,1),U,GPCE)="" ; DIS-ASOCIATE THE ENTRY FROM THE CURRENT PT GROUP

 .. I ^VEN(7.34,DA,1)'[1 D ^DIK ; DELETE THE WHOLE ENTRY IF IT IS NOT ASSOCIATED WITH ANY PATIENT GROUP!

 .. Q

 . Q

 F PCE=1:1:$L(LIST,U) D  ; REFRESH THE EXISTING 19707.34 ENTRIES BASED ON CURRENT LIST

 . S %=$P(LIST,U,PCE)

 . S CODE=$P(%,";",2) I '$L(CODE) Q

 . I CODE=0 Q

 . S NAME=$P(%,";") I '$L(NAME) Q

 . S IX=BASE_"_"_CODE

 . S DA=0,PRE=0

 . F  S DA=$O(^VEN(7.34,"AC",IX,DA)) Q:'DA  I $P($G(^VEN(7.34,DA,0)),U,3)=NAME Q  ; ANY MATCHING ENTRIES?

 . I 'DA D NS1 ; CAN'T FIND AN EXITING 19707.34 ENTRY THAT MATCHES THIS PRV, IGRP AND ICD TXT - SO MAKE ONE

 . I DA S $P(^VEN(7.34,DA,1),U,GPCE)=1 ; SET PGRP STATUS FOR THIS ENTRY = 1

 . Q

 D ^XBFMK

 Q

 ;

NS1 ; EP - MAKE A NEW ENTRY

 S DA=0,X="""`"_+PRV_""""

 D ^DIC I Y=-1 S DA=0 Q

 S DA=+Y

 S DR=".03////"_NAME_";.02////"_IGRP_";.04////"_CODE_";.06////"_IX

 L +^VEN(7.34,DA):1 I  D ^DIE L -^VEN(7.34,DA)

 Q

 ; 

EN1 ; EP - LOOP THROUGH ALL ICD & PATIENT GROUPS IN A TEMPLATE

 N LOOP S LOOP=1

 G NEW

 Q

 ; 

NEXT(EF,PRV,PGRP) ; EP - GET NEXT PRV

 N CIEN,NAME

 I EF="" S EF=$$EF("") I '$L(EF) Q 0

 S PGRP=PGRP+1 I PGRP=9 S PGRP=1

 I PGRP>1 Q EF_";"_PRV_";"_PGRP

 S EF=$$EF("") I 'EF Q ""

 S PRV=$$PRV("") I 'PRV Q ""

 S PGRP=$$PGRP(PGRP) I 'PGRP Q ""

 Q EF_";"_PRV_";"_PGRP

 ; 

UPDATE(LIST,STAT) ; EP-EDIT AN ENTRY IN THE LIST

 N DIR,X,Y,%,ENTRY,POS,NAME,CODE,DIRUT,DUOUT,DTOUT

U1 S DIR(0)="NO^1:"_$P(STAT,U,2)_":",DIR("A")="Edit entry from what position" KILL DA D ^DIR KILL DIR

 I '+Y Q LIST

 S POS=+Y

 S ENTRY=$P(LIST,U,POS) I '$L(ENTRY) Q LIST

 S DIR(0)="F^1:30",DIR("A")="Name of entry" S DIR("B")=$P(ENTRY,";")

 D ^DIR KILL DIR

 I '$D(DIRUT),'$D(DUOUT),'$D(DTOUT) S NAME=Y G U2

 Q LIST

 ; 

U2 ; EP - KEEP LOOPING?

 S CODE="",DIR(0)="FO^1:6",DIR("A")="ICD Code" S DIR("B")=$P(ENTRY,";",2)

 D ^DIR KILL DIR

 I $D(DUOUT)!($D(DTOUT)) Q LIST

 S CODE=Y

 S $P(ENTRY,";",1,2)=NAME_";"_CODE

 S $P(LIST,U,POS)=ENTRY

 W ! D SHOW(LIST) W !

 W !!,"Want to edit another entry" S %=1

 D YN^DICN I %'=1 Q LIST

 G U1

 ; 

CVT ; EP - CONVERT 7.1 TO 7.91

 S DIE="^VEN(7.1,",DA=0

 F  S DA=$O(^VEN(7.1,DA)) Q:'DA  D

 . S X=$P($G(^VEN(7.1,DA,1)),U,1)

 . I 'X Q

 . S Y=$P($G(^VEN(7.91,X,0)),U) I '$L(Y) Q

 . S Z=$S(Y="INFANT":1,Y="CHILD":2,Y="TEEN MALE":3,Y="TEEN FEMALE":4,Y="ADULT MALE":5,Y="ADULT FEMALE":6,Y="SENIOR MALE":7,Y="SENIOR FEMALE":8,1:"")

 . S DR=".04////"_Z

 . L +^VEN(7.1,DA):0 I $T D ^DIE L -^VEN(7.1,DA)

 . Q

 Q

 ; 

VENPCCMD  ; IHS/OIT/GIS - USER PREFERENCE MANAGER FOR DIAGNOSES AND ICD CODES ;

 +1       ;;2.6;PCC+;;NOV 12, 2007

 +2       ;

 +3       ;

 +4       ; 

NEW        NEW EF,PRV,PGRP,LIST,STATUS,X,Y,%,TITLE,DTOUT,DUOUT,DIRUT,%Y,IGRP,NFLG

 +1        IF '$DATA(LOOP)

               NEW LOOP

               SET LOOP=""

INIT       SET (PRV,EF)=""

           SET PGRP=0

           SET NFLG=0

 +1       ; NEW PREFERENCE LIST IS IN USE  ; PATCHED BY GIS/OIT 5/26/06 ; PCC+ 2.5 PATCH 5

           IF $DATA(^VEN(7.34,"AC"))

               IF $LENGTH($TEXT(DX^VENPCC1P))

                   SET NFLG=1

RUN        IF $DATA(IOF)

               WRITE @IOF

           WRITE !!!?20,"*****  USER PREFERENCE MANAGER FOR DIAGNOSES  *****"

 +1        WRITE !!!

LOOP       IF LOOP

               SET %=$$NEXT(EF,PRV,PGRP)

               IF '%

                   QUIT 

               WRITE !!!

               SET EF=$PIECE(%,";")

               SET PRV=$PIECE(%,";",2)

               SET PGRP=$PIECE(%,";",3)

               GOTO LST

LEF        SET EF=$$EF(EF)

 +1        IF EF=""

               IF '$GET(NFLG)

                   QUIT 

 +2        IF EF=U

               QUIT 

LPRV       SET PRV=$$PRV(PRV)

           IF PRV=""

               QUIT 

LGRP       SET PGRP=$$PGRP()

           IF PGRP=""

               QUIT 

ITEMGRP   ; GET THE ITEM GROUP

 +1        IF '$GET(NFLG)

               GOTO LST

 +2        SET IGRP=$PIECE($GET(^VEN(7.41,+$GET(EF),0)),U,18)

 +3        IF 'IGRP

               SET IGRP=$$IGRP(IGRP)

               IF 'IGRP

                   QUIT 

LST       ; LIST BASED ON 19707.1

           IF '$GET(NFLG)

               SET LIST=$$LIST(+EF,+PRV,+PGRP)

               IF 1

 +1       ; LIST BASED ON 19707.34

          IF '$TEST

               SET LIST=$$NLIST(+IGRP,+PRV,+PGRP)

 +2        SET TITLE=$$TITLE(EF,PRV,PGRP)

EDIT       SET STATUS=$$STATUS(+EF,LIST)

           WRITE !!,$PIECE(STATUS,U,3)

 +1        WRITE !,TITLE

 +2        WRITE !

           DO SHOW(LIST)

 +3        IF $LENGTH(LIST)

               WRITE !!,"Select from 'ADD', 'EDIT', 'DELETE', 'COPY', 'SUBMIT', 'NEXT LIST', 'QUIT'"

               SET DIR(0)="SBO^A:ADD;E:EDIT;D:DELETE;C:COPY;S:SUBMIT;N:NEXT LIST;Q:QUIT"

 +4        IF '$LENGTH(LIST)

               WRITE !!,"Select from 'ADD', 'COPY', 'NEXT LIST', 'QUIT'"

               SET DIR(0)="SBO^A:ADD;C:COPY;N:NEXT LIST;Q:QUIT"

 +5        SET DIR("A")="Your choice"

           KILL DA

           DO ^DIR

           KILL DIR

 +6        IF Y=U!($DATA(DTOUT))

               QUIT 

 +7        IF LOOP

               IF Y=""

                   GOTO LOOP

 +8        IF Y="A"

               SET LIST=$$ADD(LIST,STATUS)

               GOTO EDIT

 +9        IF Y="D"

               SET LIST=$$DEL(LIST,STATUS)

               GOTO EDIT

 +10       IF Y="C"

               SET LIST=$$COPY(LIST,STATUS,TITLE,EF,PRV)

               GOTO EDIT

 +11       IF Y="E"

               SET LIST=$$UPDATE(LIST,STATUS)

               GOTO EDIT

 +12       IF Y="S"

               IF $$SUBMIT(LIST,EF,PRV,PGRP)

                   GOTO RUN

               GOTO EDIT

 +13       IF Y="N"

               GOTO LPRV

 +14       QUIT 

 +15      ; 

IGRP(IGRP) ; EP - RETURN THE ICD GROUP

 +1        NEW DIC,X,Y,%

 +2        SET DIC="^VEN(7.33,"

           SET DIC(0)="AEQ"

 +3        SET DIC("A")="ICD Preference group: "

 +4        IF $GET(IGRP)

               SET DIC("B")=$PIECE($GET(^VEN(7.33,IGRP,0)),U)

 +5       IF '$TEST

               SET DIC("B")="PRIMARY"

 +6        DO ^DIC

           IF Y=-1

               QUIT ""

 +7        QUIT Y

 +8       ; 

EF(EF)    ; EP - LOOKUP EF

 +1        NEW DIC,X,Y,%

 +2        SET DIC="^VEN(7.41,"

           SET DIC(0)="AEQ"

 +3        SET DIC("A")="Encounter form name: "

 +4        IF $GET(NFLG)

               SET DIC("A")="Encounter form name (optional): "

 +5        IF $LENGTH($GET(EF))