VENPCCMA ; 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
I '$D(LOOP) N LOOP S LOOP=""
INIT S (PRV,EF)="",PGRP=0
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="" Q
LPRV S PRV=$$PRV(PRV) I PRV="" Q
LGRP S PGRP=$$PGRP() I PGRP="" Q
LST S LIST=$$LIST(+EF,+PRV,+PGRP)
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
;
EF(EF) ;
N DIC,X,Y,%
S DIC="^VEN(7.41,",DIC(0)="AEQ"
S DIC("A")="Encounter form name: "
I $L($G(EF)) S DIC("B")=$P(EF,U,2)
D ^DIC I Y=-1 Q ""
Q Y
PRV(PRV) ;
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) ;
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) ; 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")
Q MAX_U_DISP_U_X
;
TITLE(EF,PRV,G) ; TITLE OF LIST
Q $P(EF,U,2)_"/"_$P(PRV,U,2)_"/"_$P(PGRP,U,2)
;
LIST(EF,PRV,PGRP) ;
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
;
SHOW(X) ; 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) ; ADD AN ENTRY
N DIRUT,DUOUT,DTOUT,X,Y,%,DIC,POS,NAME,CODE
ADD1 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 ;
S CODE="",DIR(0)="FO^1:6",DIR("A")="ICD Code" KILL DA D ^DIR KILL DIR
I $D(DUOUT)!($D(DTOUT)) Q LIST
S CODE=Y
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) ; DELETE AN ENTRY
N DIRUT,DUOUT,DTOUT,X,Y,%,POS,ITEM,CNT,TOT
DEL1 S %=$P(STAT,U,2) I '% W !,"There are no entries to delete!" Q ""
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
;
COPY(LIST,STAT,TITLE,EF,PRV) ; 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
S CLIST=$$LIST(+EF,+PRV1,+PGRP) 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) ; ENTER THE LIST
S1 N %,CODE,DIR,Y,DIRUT,DTOUT,DUOUT
I $G(EFLAG) S Y="A" G S2
S %=$L(LIST,U)-(+$P($G(^VEN(7.41,+EF,1)),U,2)) I %>0 W !!,"You have exceeded the maximum number of items allowed!",!,"Delete ",%," item",$S(%>1:"s",1:"")," before proceeding",! H 2 Q 0
W !,"The following list will be saved: ",TITLE
; D SHOW(LIST)
W !,"Are you sure you want to submit this list"
S %=1 D YN^DICN I %'=1 Q 0
S %=$P($P(LIST,U),";",2) S CODE=$L(%)
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,TYPE) ; ORDER THE LIST: APLPHABETICAL OR BY CODE
N I,X,Y,Z,CODE,NARR,STG,ENT
I LIST="" Q ""
I TYPE'=1,TYPE'=2 Q ""
F I=1:1:$L(LIST,U) S X=$P(LIST,U,I) I $L(X) D
. S NARR=$P(X,";",1),CODE=$P(X,";",2)
. I TYPE=1,$L(NARR) S LIST(NARR,I)=CODE ; SORT BY NARRATIVE
. I TYPE=2,$L(CODE) S LIST(CODE,I)=NARR ; SORT BY CODE
. Q
S I=0,STG=""
S Y="" F S Y=$O(LIST(Y)) Q:Y="" S Z=0 F S Z=$O(LIST(Y,Z)) Q:'Z D
. S I=I+1
. S X=LIST(Y,Z)
. I TYPE=1 S ENT=Y_";"_X
. I TYPE=2 S ENT=X_";"_Y
. S $P(STG,U,I)=ENT
. Q
Q STG
;
SAVE(LIST,EF,PRV,PGRP) ; DELETE THE OLD LIST AND SAVE THE NEW ONE
I $D(^VEN(7.41,+$G(EF),0)),$L(LIST)>1,$G(PGRP),PGRP=PGRP\1,PGRP>0,PGRP<9,$D(^VA(200,+$G(PRV),0))
E W !,"Invalid parameters. No changes made. Contact site manager)" 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,VENDUZ0
S VENDUZ0=$G(DUZ(0))
D WAIT^DICD
S %="^VEN(7.1,""AG"")" K @% ; JUST TO BE SAFE, FIRST KILL OFF THE ENTIRE AG INDEX
S %=$C(68,85,90),@%@(0)=$C(64)
S DIK="^VEN(7.1,",DIK(1)=.05 D ENALL^DIK K DIK ; THEN, REINDEX AG INDEX FOR THE ENTIRE FILE
S DIK="^VEN(7.1,",IX=+PRV_"."_+PGRP
I $D(^VEN(7.1,"AG",IX)) S DA=0 F S DA=$O(^VEN(7.1,"AG",IX,DA)) Q:'DA D ^DIK ; USING THE REFRESHED INDEX, DELETE ALL ENTRIES FOR THE SPECIFIED GROUP
S DIC=DIK,DIC(0)="L",DIE=DIC,DLAYGO=19707.1 ; LAST STEP: RE-POPULATE THE FILE WITH THE NEW LIST
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 ; MAKE A NEW ENTRY - REPOPULATE THE FILE
. S DA=+Y,DR=".03////"_NAME_";.02////"_CODE_";.04////"_+PGRP
. L +^VEN(7.1,DA):5 E Q
. D ^DIE L -^VEN(7.1,DA) ; FILL IN THE FIELDS
. Q
EOJ D ^XBFMK
W !,"Changes are now in effect..." H 3
I $L($G(VENDUZ0)) S %=$C(68,85,90),@%@(0)=VENDUZ0
Q
;
EN1 ; EP FOR LOOPING THROUGH ALL ICD & PATIENT GROUPS IN A TEMPLATE
N LOOP S LOOP=1
G NEW
Q
;
NEXT(EF,PRV,PGRP) ;
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) ; 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 ;
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 ;
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
;
VENPCCMA ; 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
+1 IF '$DATA(LOOP)
NEW LOOP
SET LOOP=""
INIT SET (PRV,EF)=""
SET PGRP=0
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)
IF EF=""
QUIT
LPRV SET PRV=$$PRV(PRV)
IF PRV=""
QUIT
LGRP SET PGRP=$$PGRP()
IF PGRP=""
QUIT
LST SET LIST=$$LIST(+EF,+PRV,+PGRP)
+1 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 ;
EF(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 $LENGTH($GET(EF))
SET DIC("B")=$PIECE(EF,U,2)
+5 DO ^DIC
IF Y=-1
QUIT ""
+6 QUIT Y
PRV(PRV) ;
+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
PGRP(DFLT) ;
+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) ; 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 QUIT MAX_U_DISP_U_X
+7 ;
TITLE(EF,PRV,G) ; TITLE OF LIST
+1 QUIT $PIECE(EF,U,2)_"/"_$PIECE(PRV,U,2)_"/"_$PIECE(PGRP,U,2)
+2 ;
LIST(EF,PRV,PGRP) ;
+1 NEW INDX,SIEN,REC,X,NAME,CODE,HDR
+2 SET INDX=PRV_"."_PGRP
SET SIEN=0
SET REC=""
+3 FOR
SET SIEN=$ORDER(^VEN(7.1,"AG",INDX,SIEN))
IF 'SIEN
QUIT
Begin DoDot:1
+4 SET X=$GET(^VEN(7.1,SIEN,0))
IF '$LENGTH(X)
QUIT
+5 SET NAME=$PIECE(X,U,3)
SET CODE=$PIECE(X,U,2)
+6 IF $LENGTH(REC)
SET REC=REC_U
+7 SET REC=REC_NAME_";"_CODE
+8 QUIT
End DoDot:1
+9 QUIT REC
+10 ;
SHOW(X) ; 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) ; ADD AN ENTRY
+1 NEW DIRUT,DUOUT,DTOUT,X,Y,%,DIC,POS,NAME,CODE
ADD1 SET X=$PIECE(STAT,U)-$PIECE(STAT,U,2)
+1 IF X>0
WRITE !,"You have room for "_X_" more "_$SELECT(X>1:"entries",1:"entry")
+2 IF '$TEST
WRITE !,"You are over the limit for adding new entries!"
+3 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
QUIT LIST
CODE ;
+1 SET CODE=""
SET DIR(0)="FO^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
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) ; DELETE AN ENTRY
+1 NEW DIRUT,DUOUT,DTOUT,X,Y,%,POS,ITEM,CNT,TOT
DEL1 SET %=$PIECE(STAT,U,2)
IF '%
WRITE !,"There are no entries to delete!"
QUIT ""
+1 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 ;
COPY(LIST,STAT,TITLE,EF,PRV) ; 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 SET CLIST=$$LIST(+EF,+PRV1,+PGRP)
IF CLIST=""
WRITE !,"Unable to copy because no entries found!"
HANG 3
QUIT LIST
+7 SET CTITLE=$$TITLE(EF,PRV1,PGRP)
+8 WRITE !,CTITLE
+9 WRITE !
DO SHOW(CLIST)
+10 WRITE !,"OK to copy non-redundant entries from this list"
+11 SET %=1
DO YN^DICN
IF %'=1
QUIT LIST
+12 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
+13 WRITE !!,"Target list: ",TITLE
+14 QUIT LIST
+15 ;
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) ; ENTER THE LIST
S1 NEW %,CODE,DIR,Y,DIRUT,DTOUT,DUOUT
+1 IF $GET(EFLAG)
SET Y="A"
GOTO S2
+2 SET %=$LENGTH(LIST,U)-(+$PIECE($GET(^VEN(7.41,+EF,1)),U,2))
IF %>0
WRITE !!,"You have exceeded the maximum number of items allowed!",!,"Delete ",%," item",$SELECT(%>1:"s",1:"")," before proceeding",!
HANG 2
QUIT 0
+3 WRITE !,"The following list will be saved: ",TITLE
+4 ; D SHOW(LIST)
+5 WRITE !,"Are you sure you want to submit this list"
+6 SET %=1
DO YN^DICN
IF %'=1
QUIT 0
+7 SET %=$PIECE($PIECE(LIST,U),";",2)
SET CODE=$LENGTH(%)
+8 IF CODE
SET DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;C:SORT BY CODE AND SAVE;S:SAVE AS IS"
+9 IF '$TEST
SET DIR(0)="S^A:ALPHABETIZE THE LIST AND SAVE;S:SAVE"
+10 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,TYPE) ; ORDER THE LIST: APLPHABETICAL OR BY CODE
+1 NEW I,X,Y,Z,CODE,NARR,STG,ENT
+2 IF LIST=""
QUIT ""
+3 IF TYPE'=1
IF TYPE'=2
QUIT ""
+4 FOR I=1:1:$LENGTH(LIST,U)
SET X=$PIECE(LIST,U,I)
IF $LENGTH(X)
Begin DoDot:1
+5 SET NARR=$PIECE(X,";",1)
SET CODE=$PIECE(X,";",2)
+6 ; SORT BY NARRATIVE
IF TYPE=1
IF $LENGTH(NARR)
SET LIST(NARR,I)=CODE
+7 ; SORT BY CODE
IF TYPE=2
IF $LENGTH(CODE)
SET LIST(CODE,I)=NARR
+8 QUIT
End DoDot:1
+9 SET I=0
SET STG=""
+10 SET Y=""
FOR
SET Y=$ORDER(LIST(Y))
IF Y=""
QUIT
SET Z=0
FOR
SET Z=$ORDER(LIST(Y,Z))
IF 'Z
QUIT
Begin DoDot:1
+11 SET I=I+1
+12 SET X=LIST(Y,Z)
+13 IF TYPE=1
SET ENT=Y_";"_X
+14 IF TYPE=2
SET ENT=X_";"_Y
+15 SET $PIECE(STG,U,I)=ENT
+16 QUIT
End DoDot:1
+17 QUIT STG
+18 ;
SAVE(LIST,EF,PRV,PGRP) ; DELETE THE OLD LIST AND SAVE THE NEW ONE
+1 IF $DATA(^VEN(7.41,+$GET(EF),0))
IF $LENGTH(LIST)>1
IF $GET(PGRP)
IF PGRP=PGRP\1
IF PGRP>0
IF PGRP<9
IF $DATA(^VA(200,+$GET(PRV),0))
+2 IF '$TEST
WRITE !,"Invalid parameters. No changes made. Contact site manager)"
QUIT
+3 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,VENDUZ0
+4 SET VENDUZ0=$GET(DUZ(0))
+5 DO WAIT^DICD
+6 ; JUST TO BE SAFE, FIRST KILL OFF THE ENTIRE AG INDEX
SET %="^VEN(7.1,""AG"")"
KILL @%
+7 SET %=$CHAR(68,85,90)
SET @%@(0)=$CHAR(64)
+8 ; THEN, REINDEX AG INDEX FOR THE ENTIRE FILE
SET DIK="^VEN(7.1,"
SET DIK(1)=.05
DO ENALL^DIK
KILL DIK
+9 SET DIK="^VEN(7.1,"
SET IX=+PRV_"."_+PGRP
+10 ; USING THE REFRESHED INDEX, DELETE ALL ENTRIES FOR THE SPECIFIED GROUP
IF $DATA(^VEN(7.1,"AG",IX))
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.1,"AG",IX,DA))
IF 'DA
QUIT
DO ^DIK
+11 ; LAST STEP: RE-POPULATE THE FILE WITH THE NEW LIST
SET DIC=DIK
SET DIC(0)="L"
SET DIE=DIC
SET DLAYGO=19707.1
+12 FOR PCE=1:1:$LENGTH(LIST,U)
Begin DoDot:1
+13 SET %=$PIECE(LIST,U,PCE)
+14 SET CODE=$PIECE(%,";",2)
SET NAME=$PIECE(%,";")
+15 SET X="""`"_+PRV_""""
+16 ; MAKE A NEW ENTRY - REPOPULATE THE FILE
DO ^DIC
IF Y=-1
QUIT
+17 SET DA=+Y
SET DR=".03////"_NAME_";.02////"_CODE_";.04////"_+PGRP
+18 LOCK +^VEN(7.1,DA):5
IF '$TEST
QUIT
+19 ; FILL IN THE FIELDS
DO ^DIE
LOCK -^VEN(7.1,DA)
+20 QUIT
End DoDot:1
EOJ DO ^XBFMK
+1 WRITE !,"Changes are now in effect..."
HANG 3
+2 IF $LENGTH($GET(VENDUZ0))
SET %=$CHAR(68,85,90)
SET @%@(0)=VENDUZ0
+3 QUIT
+4 ;
EN1 ; EP FOR LOOPING THROUGH ALL ICD & PATIENT GROUPS IN A TEMPLATE
+1 NEW LOOP
SET LOOP=1
+2 GOTO NEW
+3 QUIT
+4 ;
NEXT(EF,PRV,PGRP) ;
+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) ; 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
U2 ;
+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 ;
+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 ;
