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))
SET DIC("B")=$PIECE(EF,U,2)
+6 DO ^DIC
IF X?1."^"
QUIT U
+7 IF Y=-1
QUIT ""
+8 QUIT Y
+9 ;
PRV(PRV) ; EP - LOOKUP PROVIDER
+1 NEW DIC,X,Y,%
+2 SET DIC="^VA(200,"
SET DIC(0)="AEQ"
+3 SET DIC("A")="Provider: "
+4 IF $LENGTH($GET(PRV))
SET DIC("B")=$PIECE(PRV,U,2)
+5 DO ^DIC
IF Y=-1
QUIT ""
+6 QUIT Y
+7 ;
PGRP(DFLT) ; EP - RETURN THE PATIENT GROUP
+1 NEW DIC,X,Y,%
+2 NEW DIR,DTOUT,DIRUT,DUOUT
+3 SET 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"
+4 IF $GET(DFLT)
IF DFLT>0
IF DFLT<9
SET %=$PIECE(DIR(0),(DFLT_":"),2)
SET %=$PIECE(%,";")
QUIT DFLT_U_%
+5 SET DIR("A")="Patient group"
KILL DA
DO ^DIR
KILL DIR
+6 IF 'Y
QUIT ""
+7 QUIT Y_U_Y(0)
+8 ;
STATUS(EF,X) ; EP - SHOW MAX ENTRIES POSSIBLE
+1 NEW DISP,MAX
+2 SET DISP=$LENGTH(X,U)
+3 IF X=""
SET DISP=0
+4 SET MAX=+$PIECE($GET(^VEN(7.41,+EF,1)),U,2)
+5 SET X="There is room for "_MAX_" entries on this form"
IF DISP
SET X=X_" and you have selected "_DISP_$SELECT(DISP=1:" entry",1:" entries")
+6 IF $GET(NFLG)
IF DISP
SET X="You have selected "_DISP_$SELECT(DISP=1:" entry",1:" entries")_" so far"
+7 QUIT MAX_U_DISP_U_X
+8 ;
TITLE(EF,PRV,G) ; EP - TITLE OF LIST
+1 NEW %
+2 SET %=$PIECE(PRV,U,2)_"/"_$PIECE(PGRP,U,2)
+3 IF $LENGTH($GET(EF))
SET %=%_"/"_$PIECE(EF,U,2)_"/"
+4 QUIT %
+5 ;
LIST(EF,PRV,PGRP) ; EP - CREATED THE ICD LIST
+1 ; USE NEW ICD PREF FILE
IF $GET(NFLG)
GOTO NLIST
+2 NEW INDX,SIEN,REC,X,NAME,CODE,HDR
+3 SET INDX=PRV_"."_PGRP
SET SIEN=0
SET REC=""
+4 FOR
SET SIEN=$ORDER(^VEN(7.1,"AG",INDX,SIEN))
IF 'SIEN
QUIT
Begin DoDot:1
+5 SET X=$GET(^VEN(7.1,SIEN,0))
IF '$LENGTH(X)
QUIT
+6 SET NAME=$PIECE(X,U,3)
SET CODE=$PIECE(X,U,2)
+7 IF $LENGTH(REC)
SET REC=REC_U
+8 SET REC=REC_NAME_";"_CODE
+9 QUIT
End DoDot:1
+10 QUIT REC
+11 ;
NLIST(IGRP,PRV,PGRP) ; EP - RAW PREFERENCE LIST FOR A PROVIDER, ICD GROUP, AND PT GRP
+1 NEW SIEN,REC,X,NAME,CODE,HDR,ROOT,PCE,GRP
+2 SET SIEN=0
SET REC=""
+3 SET PCE=$PIECE("1^3^7^5^11^9^15^13",U,PGRP)
+4 FOR
SET SIEN=$ORDER(^VEN(7.34,SIEN))
IF 'SIEN
QUIT
Begin DoDot:1
+5 SET GRP=$PIECE($GET(^VEN(7.34,SIEN,1)),U,PCE)
IF 'GRP
QUIT
+6 SET X=$GET(^VEN(7.34,SIEN,0))
IF '$LENGTH(X)
QUIT
+7 IF +X'=PRV
QUIT
+8 IF $PIECE(X,U,2)'=IGRP
QUIT
+9 SET NAME=$PIECE(X,U,3)
IF '$LENGTH(NAME)
QUIT
+10 SET CODE=$PIECE(X,U,4)
IF '$LENGTH(CODE)
QUIT
+11 IF $LENGTH(REC)
SET REC=REC_U
+12 SET REC=REC_NAME_";"_CODE
+13 IF $$ICD^VENPCCU(CODE)
WRITE !,CODE," IS AN INVALID ICD CODE!!!"
+14 QUIT
End DoDot:1
+15 QUIT REC
+16 ;
SHOW(X) ; EP-DISPLAY THE LIST
+1 NEW NAME,CODE,I,Y,STOP
+2 FOR I=1:1:$LENGTH(X,U)
Begin DoDot:1
+3 SET Y=$PIECE(X,U,I)
+4 IF Y=""
IF I=1
WRITE !,"No entries found!"
QUIT
+5 SET NAME=$PIECE(Y,";")
SET CODE=$PIECE(Y,";",2)
WRITE !
+6 IF '(I#18)
SET STOP='$$WAIT^VENPCCU
IF STOP
QUIT
+7 WRITE I,?5,NAME," ",CODE
+8 QUIT
End DoDot:1
IF $GET(STOP)
QUIT
+9 QUIT
+10 ;
ADD(LIST,STAT) ; EP-ADD AN ENTRY
+1 NEW DIRUT,DUOUT,DTOUT,X,Y,%,DIC,POS,NAME,CODE
ADD1 IF $GET(NFLG)
WRITE !
GOTO POS
+1 SET X=$PIECE(STAT,U)-$PIECE(STAT,U,2)
+2 IF X>0
WRITE !,"You have room for "_X_" more "_$SELECT(X>1:"entries",1:"entry")
+3 IF '$TEST
WRITE !,"You are over the limit for adding new entries!"
+4 WRITE !
POS ;
+1 IF '$LENGTH(LIST)
SET POS=1
GOTO NAME
+2 SET DIR("A")="Insert new entry at what position? (1 - END of list)"
+3 SET DIR(0)="F^1:3"
SET DIR("B")="END"
KILL DA
DO ^DIR
KILL DIR
SET POS=Y
+4 IF $DATA(DIRUT)
KILL DIRUT,DTOUT,DUOUT,DIROUT
QUIT LIST
P1 IF POS=$EXTRACT("END of list",1,$LENGTH(POS))
WRITE $EXTRACT("END of list",$LENGTH(POS)+1,99)
SET POS=1+$PIECE(STAT,U,2)
GOTO NAME
+1 IF POS
IF POS>0
IF POS'>$PIECE(STAT,U,2)
+2 IF '$TEST
WRITE " ??"
GOTO POS
NAME ;
+1 SET DIR(0)="F^1:30"
SET DIR("A")="Name of entry"
KILL DA
DO ^DIR
KILL DIR
+2 IF '$DATA(DIRUT)
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
SET NAME=Y
GOTO CODE
+3 KILL DIRUT,DTOUT,DUOUT
+4 QUIT LIST
+5 ;
CODE ; EP - GET ICD CODE
+1 SET CODE=""
SET DIR(0)="F^1:6"
SET DIR("A")="ICD Code"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT LIST
+3 SET CODE=Y
+4 SET %=$$ICD^VENPCCU($GET(CODE))
+5 IF '%
WRITE !,"Invalid ICD code!!! Try again...",!!
GOTO CODE
+6 ; CONFIRMATION
WRITE " (",$PIECE($GET(^ICD9(%,0)),U,3),")"
ENT ;
+1 IF $PIECE(LIST,U,POS)=""
SET $PIECE(LIST,U,POS)=NAME_";"_CODE
+2 IF '$TEST
SET %=$PIECE(LIST,U,POS)
SET $PIECE(LIST,U,POS)=NAME_";"_CODE_U_%
+3 SET %=$PIECE(STAT,U,2)+1
SET $PIECE(STAT,U,2)=%
+4 WRITE !
DO SHOW(LIST)
WRITE !
+5 WRITE !!,"Want to add another entry"
SET %=1
+6 DO YN^DICN
IF %'=1
QUIT LIST
+7 GOTO ADD1
+8 ;
DEL(LIST,STAT) ;EP - DELETE AN ENTRY
+1 NEW DIRUT,DUOUT,DTOUT,X,Y,%,POS,ITEM,CNT,TOT
DEL1 SET %=$PIECE(STAT,U,2)
IF '%
Begin DoDot:1
+1 WRITE !,"There are no more entries to delete!"
+2 ; KILL OF ALL ENTRIES IN THE ICD FILE
IF '$GET(NFLG)
DO WIPE
QUIT
+3 DO NWIPE
+4 QUIT
End DoDot:1
QUIT ""
+5 IF '$GET(NFLG)
SET %=((+STAT)-($PIECE(STAT,U,2)))
IF %<0
SET %=%*-1
WRITE !,"You should delete at least "_%_" entries..."
DEL2 SET DIR(0)="FO^"
SET DIR("A")="Delete entry from what position"
KILL DA
+1 SET (HELP,DIR("?"))="Enter a number, a range (e.g., '1-32'), or '*' (all)"
+2 DO ^DIR
KILL DIR
+3 IF Y?1."^"
QUIT LIST
+4 IF Y=+Y
IF Y>0
IF Y=(Y\1)
SET POS=+Y
GOTO CKD
+5 IF Y="*"!(Y="ALL")!(Y="all")
SET Y="*"
SET POS=1
SET POS(1)=$PIECE(STAT,U,2)
GOTO CKD
+6 IF Y?1.3N1"-"1.3N
SET POS=+Y
SET POS(1)=$PIECE(Y,"-",2)
+7 IF '$GET(POS)
WRITE !,HELP
GOTO DEL2
CKD IF POS>$PIECE(STAT,U,2)!(+$GET(POS(1))>$PIECE(STAT,U,2))
WRITE !,"Select a number between 1 and ",$PIECE(STAT,U,2)
KILL POS
GOTO DEL2
+1 WRITE !,"Sure you want to delete "_$SELECT(Y=+Y:$PIECE($PIECE(LIST,U,POS),";"),Y["-":Y,1:"ALL")
+2 SET %=1
DO YN^DICN
IF $DATA(DIRUT)!($DATA(DTOUT))
QUIT LIST
+3 IF %'=1
GOTO DEL2
+4 IF $GET(POS(1))
SET CNT=0
SET TOT=POS(1)-POS
DLOOP SET ITEM=$TRANSLATE($PIECE(LIST,U,POS),";"," ")
+1 IF POS=$PIECE(STAT,U,2)
SET LIST=$PIECE(LIST,U,1,POS-1)
GOTO DEL3
+2 IF POS=1
SET LIST=$PIECE(LIST,U,2,99)
GOTO DEL3
+3 SET LIST=$PIECE(LIST,U,1,POS-1)_U_$PIECE(LIST,U,POS+1,99)
DEL3 SET %=$PIECE(STAT,U,2)-1
SET $PIECE(STAT,U,2)=%
+1 WRITE !," Deleting ",ITEM
+2 IF $GET(POS(1))
SET CNT=CNT+1
IF CNT'>TOT
GOTO DLOOP
+3 KILL ITEM,CNT,TOT,POS
+4 IF '$LENGTH(LIST)
GOTO DEL1
+5 WRITE !!,"Want to delete another entry"
SET %=1
+6 DO YN^DICN
IF %'=1
QUIT LIST
+7 DO SHOW(LIST)
+8 GOTO DEL1
+9 ;
WIPE ; EP - CLEAN OUT ALL 19707.1 ENTRIES FOR A PROVIDER AND PT GROUP
+1 NEW DA,DIK,IX
+2 IF '$DATA(^VA(200,+$GET(PRV),0))
QUIT
+3 IF '$GET(PGRP)
QUIT
+4 SET DIK="^VEN(7.1,"
SET DA=0
+5 SET IX=+PRV_"."_+PGRP
+6 FOR
SET DA=$ORDER(^VEN(7.1,"AG",IX,DA))
IF 'DA
QUIT
DO ^DIK
+7 DO ^XBFMK
+8 QUIT
+9 ;
NWIPE ; EP - CLEAN OUT ALL 19707.34 FOR ENTRIES FOR A PROVIDER, ICD GROUP, AND PT GROUP
+1 NEW DA,DIK,IX,BASE,PCE
+2 IF '$DATA(^VA(200,+$GET(PRV),0))
QUIT
+3 IF '$GET(PGRP)
QUIT
+4 IF '$DATA(^VEN(7.33,+$GET(IGRP),0))
QUIT
+5 SET PCE=$PIECE("1^3^7^5^11^9^15^13",U,PGRP)
+6 SET DIK="^VEN(7.1,"
SET DA=0
+7 SET (IX,BASE)=+PRV_"_"_+IGRP
+8 FOR
SET IX=$ORDER(^VEN(7.34,"AC",IX))
IF IX=""
QUIT
IF $PIECE(IX,"_",1,2)'=BASE
QUIT
Begin DoDot:1
+9 SET DA=0
+10 FOR
SET DA=$ORDER(^VEN(7.34,"AC",IX,DA))
IF 'DA
QUIT
Begin DoDot:2
+11 IF '$DATA(^VEN(7.34,DA,1))
QUIT
+12 SET $PIECE(^VEN(7.34,DA,1),U,PCE)=""
+13 IF ^VEN(7.34,DA,1)'[1
DO ^DIK
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 DO ^XBFMK
+17 QUIT
+18 ;
COPY(LIST,STAT,TITLE,EF,PRV) ; EP-COPY IN ANOTHER LIST
+1 NEW PGRP,CTITLE,CLIST,DUOUT,DIRUT,DTOUT,I
+2 WRITE !,"Enter name of provider to copy from =>"
+3 SET PRV1=$$PRV
IF 'PRV1
QUIT LIST
+4 WRITE !!,"Define the Patient Group to copy from =>"
+5 SET PGRP=$$PGRP
IF PGRP=""
QUIT LIST
+6 ; LIST BASED ON 19707.1
IF '$GET(NFLG)
SET CLIST=$$LIST(+EF,+PRV1,+PGRP)
IF 1
+7 ; LIST BASED ON 19707.34
IF '$TEST
SET CLIST=$$NLIST(+IGRP,+PRV1,+PGRP)
+8 IF CLIST=""
WRITE !,"Unable to copy because no entries found!"
HANG 3
QUIT LIST
+9 SET CTITLE=$$TITLE(EF,PRV1,PGRP)
+10 WRITE !,CTITLE
+11 WRITE !
DO SHOW(CLIST)
+12 WRITE !,"OK to copy non-redundant entries from this list"
+13 SET %=1
DO YN^DICN
IF %'=1
QUIT LIST
+14 FOR I=1:1:$LENGTH(CLIST,U)
SET X=$PIECE(CLIST,U,I)
IF LIST'[X
IF LIST'=""
SET LIST=LIST_U
SET LIST=LIST_X
+15 WRITE !!,"Target list: ",TITLE
+16 QUIT LIST
+17 ;
SUB(LIST,EF,PRV,PGRP) ; EP FOR SUBMITTING AN EXTERNALY GENERATED LIST
+1 NEW EFLAG
SET EFLAG=1
+2 GOTO S1
+3 ;
SUBMIT(LIST,EF,PRV,PGRP) ; EP-ENTER THE LIST
S1 NEW %,CODE,DIR,Y,DIRUT,DTOUT,DUOUT,EX
+1 IF $GET(EFLAG)
SET Y="A"
GOTO S2
+2 IF '$GET(NFLG)
Begin DoDot:1
+3 SET EX=$LENGTH(LIST,U)-(+$PIECE($GET(^VEN(7.41,+EF,1)),U,2))
+4 IF EX<1
QUIT
+5 WRITE !!,"You have exceeded the maximum number of items allowed!"
+6 WRITE !,"Delete ",EX," item",$SELECT(EX>1:"s",1:"")," before proceeding",!
+7 HANG 2
+8 QUIT
End DoDot:1
IF EX>0
QUIT 0
+9 WRITE !,"The following list will be saved: ",TITLE
+10 DO SHOW(LIST)
+11 WRITE !,"Are you sure everything is OK"
+12 SET %=1
DO YN^DICN
IF %'=1
QUIT 0
+13 SET %=$PIECE($PIECE(LIST,U),";",2)
SET CODE=$LENGTH(%)
+14 IF $GET(NFLG)
SET Y="S"
WRITE " <- SAVED!"
GOTO S2
+15 IF CODE
SET DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;C:SORT BY CODE AND SAVE;S:SAVE AS IS"
+16 IF '$TEST
SET DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;S:SAVE"
+17 SET DIR("A")="Your choice"
KILL DA
DO ^DIR
KILL DIR
S2 IF Y="A"
SET LIST=$$ALPH(LIST,1)
DO SAVE(LIST,EF,PRV,PGRP)
QUIT 1
+1 IF Y="C"
SET LIST=$$ALPH(LIST,2)
DO SAVE(LIST,EF,PRV,PGRP)
QUIT 1
+2 IF Y="S"
DO SAVE(LIST,EF,PRV,PGRP)
QUIT 1
+3 QUIT 0
+4 ;
ALPH(LIST,PCE) ; EP-ALPHABETIZE THE LIST
+1 NEW I,X,Y,Z
+2 FOR I=1:1:$LENGTH(LIST,U)
SET X=$PIECE(LIST,U,I)
IF $LENGTH(X)
Begin DoDot:1
+3 SET Y=$PIECE(X,";",PCE)
+4 SET LIST(Y)=I
+5 QUIT
End DoDot:1
+6 SET I=0
SET Z=""
+7 SET Y=""
FOR
SET Y=$ORDER(LIST(Y))
IF Y=""
QUIT
Begin DoDot:1
+8 SET I=I+1
+9 SET $PIECE(Z,U,I)=$PIECE(LIST,U,LIST(Y))
+10 QUIT
End DoDot:1
+11 QUIT Z
+12 ;
SAVE(LIST,EF,PRV,PGRP) ; EP-DELETE THE OLD LIST AND SAVE THE NEW ONE
+1 IF $GET(NFLG)
GOTO NSAVE
+2 IF $DATA(^VEN(7.41,+$GET(EF),0))
IF $LENGTH(LIST)
IF PGRP
IF PGRP=PGRP\1
IF PGRP>0
IF PGRP<9
+3 IF '$TEST
QUIT
+4 NEW 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
+5 SET DIK="^VEN(7.1,"
+6 SET IX=+PRV_"."_+PGRP
+7 SET DA=0
FOR
SET DA=$ORDER(^VEN(7.1,"AG",IX,DA))
IF 'DA
QUIT
DO ^DIK
+8 SET DIC=DIK
SET DIC(0)="L"
SET DIE=DIC
SET DLAYGO=19707.1
+9 FOR PCE=1:1:$LENGTH(LIST,U)
Begin DoDot:1
+10 SET %=$PIECE(LIST,U,PCE)
+11 SET CODE=$PIECE(%,";",2)
SET NAME=$PIECE(%,";")
+12 SET X="""`"_+PRV_""""
+13 DO ^DIC
IF Y=-1
QUIT
+14 SET DA=+Y
SET DR=".03////"_NAME_";.02////"_CODE_";.04////"_+PGRP
+15 LOCK +^VEN(7.1,DA):5
IF $TEST
DO ^DIE
LOCK -^VEN(7.1,DA)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
NSAVE ; EP - SAVE TO NEW ICD FILE 19707.34
+1 IF $LENGTH($GET(LIST))
IF $GET(PRV)
IF $GET(PGRP)
IF $GET(IGRP)
+2 IF '$TEST
QUIT
+3 NEW DIC,DIE,DA,DR,X,Y,NAME,CODE,DIK,IX,BASE,PCE,GPCE,FLD,TXT,IIEN,PRE
+4 SET GPCE=$PIECE("1^3^7^5^11^9^15^13",U,PGRP)
+5 SET (DIC,DIE,DIK)="^VEN(7.34,"
SET DIC(0)="L"
SET DLAYGO=19707.34
+6 SET (IX,BASE)=+PRV_"_"_+IGRP
+7 ; WIPE ALL EXISTING PRV/PGRP 19707.34 ENTRIES
FOR
SET IX=$ORDER(^VEN(7.34,"AC",IX))
IF IX=""
QUIT
IF $PIECE(IX,"_",1,2)'=BASE
QUIT
Begin DoDot:1
+8 SET DA=0
+9 ; IT IS POSSIBLE TO HAVE MULTIPLE ENTRIES FOR A SINGLE ICD CODE!
FOR
SET DA=$ORDER(^VEN(7.34,"AC",IX,DA))
IF 'DA
QUIT
Begin DoDot:2
+10 ; THIS ENTRY IS NOT ASSOCIATED WITH THE CURRENT PT GROUP, SO QUIT
IF '$PIECE($GET(^VEN(7.34,DA,1)),U,GPCE)
QUIT
+11 ; DIS-ASOCIATE THE ENTRY FROM THE CURRENT PT GROUP
SET $PIECE(^VEN(7.34,DA,1),U,GPCE)=""
+12 ; DELETE THE WHOLE ENTRY IF IT IS NOT ASSOCIATED WITH ANY PATIENT GROUP!
IF ^VEN(7.34,DA,1)'[1
DO ^DIK
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ; REFRESH THE EXISTING 19707.34 ENTRIES BASED ON CURRENT LIST
FOR PCE=1:1:$LENGTH(LIST,U)
Begin DoDot:1
+16 SET %=$PIECE(LIST,U,PCE)
+17 SET CODE=$PIECE(%,";",2)
IF '$LENGTH(CODE)
QUIT
+18 IF CODE=0
QUIT
+19 SET NAME=$PIECE(%,";")
IF '$LENGTH(NAME)
QUIT
+20 SET IX=BASE_"_"_CODE
+21 SET DA=0
SET PRE=0
+22 ; ANY MATCHING ENTRIES?
FOR
SET DA=$ORDER(^VEN(7.34,"AC",IX,DA))
IF 'DA
QUIT
IF $PIECE($GET(^VEN(7.34,DA,0)),U,3)=NAME
QUIT
+23 ; CAN'T FIND AN EXITING 19707.34 ENTRY THAT MATCHES THIS PRV, IGRP AND ICD TXT - SO MAKE ONE
IF 'DA
DO NS1
+24 ; SET PGRP STATUS FOR THIS ENTRY = 1
IF DA
SET $PIECE(^VEN(7.34,DA,1),U,GPCE)=1
+25 QUIT
End DoDot:1
+26 DO ^XBFMK
+27 QUIT
+28 ;
NS1 ; EP - MAKE A NEW ENTRY
+1 SET DA=0
SET X="""`"_+PRV_""""
+2 DO ^DIC
IF Y=-1
SET DA=0
QUIT
+3 SET DA=+Y
+4 SET DR=".03////"_NAME_";.02////"_IGRP_";.04////"_CODE_";.06////"_IX
+5 LOCK +^VEN(7.34,DA):1
IF $TEST
DO ^DIE
LOCK -^VEN(7.34,DA)
+6 QUIT
+7 ;
EN1 ; EP - LOOP THROUGH ALL ICD & PATIENT GROUPS IN A TEMPLATE
+1 NEW LOOP
SET LOOP=1
+2 GOTO NEW
+3 QUIT
+4 ;
NEXT(EF,PRV,PGRP) ; EP - GET NEXT PRV
+1 NEW CIEN,NAME
+2 IF EF=""
SET EF=$$EF("")
IF '$LENGTH(EF)
QUIT 0
+3 SET PGRP=PGRP+1
IF PGRP=9
SET PGRP=1
+4 IF PGRP>1
QUIT EF_";"_PRV_";"_PGRP
+5 SET EF=$$EF("")
IF 'EF
QUIT ""
+6 SET PRV=$$PRV("")
IF 'PRV
QUIT ""
+7 SET PGRP=$$PGRP(PGRP)
IF 'PGRP
QUIT ""
+8 QUIT EF_";"_PRV_";"_PGRP
+9 ;
UPDATE(LIST,STAT) ; EP-EDIT AN ENTRY IN THE LIST
+1 NEW DIR,X,Y,%,ENTRY,POS,NAME,CODE,DIRUT,DUOUT,DTOUT
U1 SET DIR(0)="NO^1:"_$PIECE(STAT,U,2)_":"
SET DIR("A")="Edit entry from what position"
KILL DA
DO ^DIR
KILL DIR
+1 IF '+Y
QUIT LIST
+2 SET POS=+Y
+3 SET ENTRY=$PIECE(LIST,U,POS)
IF '$LENGTH(ENTRY)
QUIT LIST
+4 SET DIR(0)="F^1:30"
SET DIR("A")="Name of entry"
SET DIR("B")=$PIECE(ENTRY,";")
+5 DO ^DIR
KILL DIR
+6 IF '$DATA(DIRUT)
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
SET NAME=Y
GOTO U2
+7 QUIT LIST
+8 ;
U2 ; EP - KEEP LOOPING?
+1 SET CODE=""
SET DIR(0)="FO^1:6"
SET DIR("A")="ICD Code"
SET DIR("B")=$PIECE(ENTRY,";",2)
+2 DO ^DIR
KILL DIR
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT LIST
+4 SET CODE=Y
+5 SET $PIECE(ENTRY,";",1,2)=NAME_";"_CODE
+6 SET $PIECE(LIST,U,POS)=ENTRY
+7 WRITE !
DO SHOW(LIST)
WRITE !
+8 WRITE !!,"Want to edit another entry"
SET %=1
+9 DO YN^DICN
IF %'=1
QUIT LIST
+10 GOTO U1
+11 ;
CVT ; EP - CONVERT 7.1 TO 7.91
+1 SET DIE="^VEN(7.1,"
SET DA=0
+2 FOR
SET DA=$ORDER(^VEN(7.1,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 SET X=$PIECE($GET(^VEN(7.1,DA,1)),U,1)
+4 IF 'X
QUIT
+5 SET Y=$PIECE($GET(^VEN(7.91,X,0)),U)
IF '$LENGTH(Y)
QUIT
+6 SET Z=$SELECT(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:"")
+7 SET DR=".04////"_Z
+8 LOCK +^VEN(7.1,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.1,DA)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
