VENPCCMP.m

VENPCCMP ; IHS/OIT/GIS - ORDERABLE PREFERENCE MANAGER ;

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

 ;

 ; DEAD CODE IN 2.5

 ; 

NEW N EF,CPT,PGRP,LIST,STATUS,X,Y,%,TITLE,DTOUT,DUOUT,DIRUT,%Y

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

INIT S (CPT,EF)="",PGRP=0

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

 W !!!

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

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

LCPT S CPT=$$CPT(CPT) I CPT="" Q

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

LST S LIST=$$LIST(+EF,+CPT,PGRP)

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

EDIT S STATUS=$$STATUS(+EF,+CPT,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^VENPCCMD(LIST,STATUS) G EDIT

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

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

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

 I Y="N" G LCPT

 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

CPT(CPT) ;

 N DIC,X,Y,%

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

 S DIC("A")="Section of form: "

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

 S DIC("S")="N % S %=$P(^(0),U) I %'=""PHYSICAL EXAM"",%'=""HEALTH MAINTENANCE REMINDERS"""

 D ^DIC I Y=-1 Q ""

 Q Y

PGRP() ; 

 N DIC,X,Y,%

 N DIR,DTOUT,DIRUT,DUOUT

 S DIR(0)="S^1:Infants;2:Children;3:Adult Males;4:Adult Females",DIR("A")="Patient group" KILL DA D ^DIR KILL DIR

 I 'Y Q ""

 Q Y

 ; 

STATUS(EF,CPT,X) ; SHOW MAX ENTRIES POSSIBLE

 N DISP,MAX

 S DISP=$L(X,U)

 I X="" S DISP=0

 S MAX=$$MAX(+EF,+CPT)

 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,CPT,G) ; TITLE OF LIST

 Q $P(EF,U,2)_"/"_$P(CPT,U,2)_"/"_$S(G=1:"INFANTS",G=2:"CHILDREN",G=3:"ADULT MALES",1:"ADULT FEMALES")

 ; 

LIST(EF,CPT,PGRP) ;  EP-LIST THE ITEMS

 N MN,GRP,SIEN,REC,X,NAME,CODE,HDR,CTAG,STAG

 S MN=$P($G(^VEN(7.98,CPT,0)),U,3)

 S GRP=PGRP_MN,SIEN=0,REC=""

 F  S SIEN=$O(^VEN(7.93,"AC",GRP,SIEN)) Q:'SIEN  D

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

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

 . S CTAG=$TR($G(^VEN(7.93,SIEN,1)),U,"|")

 . S STAG=$TR($G(^VEN(7.93,SIEN,2)),U,"|")

 . I $L(REC) S REC=REC_U

 . S REC=REC_NAME_";"_CODE_";"_CTAG_";"_STAG

 . 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

 . W !

 . I '(I#20),'$$WAIT^VENPCCU S STOP=1 Q

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

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

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

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

 . Q

 Q

 ; 

ADD(LIST,STAT) ; ADD AN ENTRY

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

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,DIROUT,DUOUT Q LIST

CODE ; 

 S CODE="",DIR(0)="FO^1:6",DIR("A")="CPT 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

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)="NO^1:"_$P(STAT,U,2)_":",DIR("A")="Delete entry from what position" KILL DA D ^DIR KILL DIR

 I '+Y Q LIST

 S POS=+Y

 W !,"Sure you want to delete "_$P($P(LIST,U,POS),";")

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

 I %'=1 G DEL2

 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 ! D SHOW(LIST) W !

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

 D YN^DICN I %'=1 Q LIST

 G DEL1

 ; 

COPY(LIST,STAT,TITLE,EF,CPT) ; COPY IN ANOTHER LIST

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

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

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

 S CLIST=$$LIST(+EF,+CPT,PGRP) I CLIST="" W !,"Unable to copy because no entries found!" H 3 Q LIST

 S CTITLE=$$TITLE(EF,CPT,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 !!,"Source list: ",TITLE

 W ! D SHOW(LIST)

 Q LIST

 ; 

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

 N EFLAG S EFLAG=1

 G S1

 ; 

SUBMIT(LIST,EF,CPT,PGRP) ; ENTER THE LIST

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

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

 S %=$L(LIST,U)-$$MAX(+EF,+CPT) 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 everything is OK"

 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"

 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,CPT,PGRP) Q 1

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

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

 Q 0

 ; 

ALPH(LIST,PCE) ; 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,CPT,PGRP) ; EP-DELETE THE OLD LIST AND SAVE THE NEW ONE

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

 E  Q

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

 S DIK="^VEN(7.93,"

 S MN=$P($G(^VEN(7.98,+CPT,0)),U,3)

 S IX=PGRP_MN

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

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

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

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

 . S CODE=$P(%,";",2),CTAG=$P(%,";",3),STAG=$P(%,";",4)

 . S X=""""_$P(%,";")_"""",HDR=MN_PCE

 . S HIEN=$O(^VEN(7.42,"B",HDR,0)) I 'HIEN Q

 . D ^DIC I Y=-1 Q

 . S DA=+Y,DR=".02////"_$P($G(^VEN(7.41,+$G(EF),0)),U,9)_";.03////"_HIEN_";.06////"_CODE_";.09////"_+PGRP_";.11////"_+EF_";1////"_$TR(CTAG,"|",U)_";2////"_$TR(STAG,"|",U)

 . L +^VEN(7.93,DA):5 E  Q

 . D ^DIE L -^VEN(7.93,DA)

 . Q

 Q

 ; 

EN1 ; EP FOR LOOPING THROUGH ALL CPT & PATIENT GROUPS IN A TEMPLATE

 N LOOP S LOOP=1

 G NEW

 Q

 ; 

NEXT(EF,CPT,PGRP) ;

 N CIEN,NAME

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

 S PGRP=PGRP+1 I PGRP=5 S PGRP=1

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

N1 S CIEN=$O(^VEN(7.98,+CPT)),NAME=$P($G(^VEN(7.98,+CIEN,0)),U),CPT=CIEN_U_NAME

 I 'CPT W !!,"You have successfully edited this template!" Q 0

 I NAME="HEALTH MAINTENANCE REMINDERS" G N1

 I NAME="PHYSICAL EXAM" G N1

 Q EF_";"_CPT_";"_PGRP

 ; 

MAX(EF,CPT) ; EP-MAX ITEMS

 N MN,X,I,Y,SS,PCE,MAX

 S MN=$P($G(^VEN(7.98,CPT,0)),U,2)

 I '$L(MN) Q ""

 S X="EXA;1;3^HMR;1;4^IMM;1;5^INJ;1;6^LAB;1;7^EDU;1;8^PEX;1;9^RAD;2;1^SUP;2;2^TRE;2;3"

 F I=1:1:$L(X,U) S Y=$P(X,U,I) I $P(Y,";")=MN S SS=$P(Y,";",2),PCE=$P(Y,";",3) Q

 I '$G(PCE) Q ""

 S MAX=$P($G(^VEN(7.41,EF,SS)),U,PCE)

 Q MAX

 ; 

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")="CPT 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

 ; 

VENPCCMP  ; IHS/OIT/GIS - ORDERABLE PREFERENCE MANAGER ;

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

 +2       ;

 +3       ; DEAD CODE IN 2.5

 +4       ; 

NEW        NEW EF,CPT,PGRP,LIST,STATUS,X,Y,%,TITLE,DTOUT,DUOUT,DIRUT,%Y

 +1        IF '$DATA(LOOP)

               NEW LOOP

               SET LOOP=""

INIT       SET (CPT,EF)=""

           SET PGRP=0

RUN        IF $DATA(IOF)

               WRITE @IOF

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

 +1        WRITE !!!

LOOP       IF LOOP

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

               IF '%

                   QUIT 

               WRITE !!!

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

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

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

               GOTO LST

LEF        SET EF=$$EF(EF)

           IF EF=""

               QUIT 

LCPT       SET CPT=$$CPT(CPT)

           IF CPT=""

               QUIT 

LGRP       SET PGRP=$$PGRP()

           IF PGRP=""

               QUIT 

LST        SET LIST=$$LIST(+EF,+CPT,PGRP)

 +1        SET TITLE=$$TITLE(EF,CPT,PGRP)

EDIT       SET STATUS=$$STATUS(+EF,+CPT,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^VENPCCMD(LIST,STATUS)

               GOTO EDIT

 +10       IF Y="C"

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

               GOTO EDIT

 +11       IF Y="E"

               SET LIST=$$UPDATE(LIST,STATUS)

               GOTO EDIT

 +12       IF Y="S"

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

                   GOTO RUN

               GOTO EDIT

 +13       IF Y="N"

               GOTO LCPT

 +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

CPT(CPT)  ;

 +1        NEW DIC,X,Y,%

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

           SET DIC(0)="AEQ"

 +3        SET DIC("A")="Section of form: "

 +4        IF $LENGTH($GET(CPT))

               SET DIC("B")=$PIECE(CPT,U,2)

 +5        SET DIC("S")="N % S %=$P(^(0),U) I %'=""PHYSICAL EXAM"",%'=""HEALTH MAINTENANCE REMINDERS"""

 +6        DO ^DIC

           IF Y=-1

               QUIT ""

 +7        QUIT Y

PGRP()    ; 

 +1        NEW DIC,X,Y,%

 +2        NEW DIR,DTOUT,DIRUT,DUOUT

 +3        SET DIR(0)="S^1:Infants;2:Children;3:Adult Males;4:Adult Females"

           SET DIR("A")="Patient group"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF 'Y

               QUIT ""

 +5        QUIT Y

 +6       ; 

STATUS(EF,CPT,X) ; SHOW MAX ENTRIES POSSIBLE

 +1        NEW DISP,MAX

 +2        SET DISP=$LENGTH(X,U)

 +3        IF X=""

               SET DISP=0

 +4        SET MAX=$$MAX(+EF,+CPT)

 +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,CPT,G) ; TITLE OF LIST

 +1        QUIT $PIECE(EF,U,2)_"/"_$PIECE(CPT,U,2)_"/"_$SELECT(G=1:"INFANTS",G=2:"CHILDREN",G=3:"ADULT MALES",1:"ADULT FEMALES")

 +2       ; 

LIST(EF,CPT,PGRP) ;  EP-LIST THE ITEMS

 +1        NEW MN,GRP,SIEN,REC,X,NAME,CODE,HDR,CTAG,STAG

 +2        SET MN=$PIECE($GET(^VEN(7.98,CPT,0)),U,3)

 +3        SET GRP=PGRP_MN

           SET SIEN=0

           SET REC=""

 +4        FOR 

               SET SIEN=$ORDER(^VEN(7.93,"AC",GRP,SIEN))

               IF 'SIEN

                   QUIT 

               Begin DoDot:1

 +5                SET X=$GET(^VEN(7.93,SIEN,0))

                   IF '$LENGTH(X)

                       QUIT 

 +6                SET NAME=$PIECE(X,U)

                   SET CODE=$PIECE(X,U,6)

 +7                SET CTAG=$TRANSLATE($GET(^VEN(7.93,SIEN,1)),U,"|")

 +8                SET STAG=$TRANSLATE($GET(^VEN(7.93,SIEN,2)),U,"|")

 +9                IF $LENGTH(REC)

                       SET REC=REC_U

 +10               SET REC=REC_NAME_";"_CODE_";"_CTAG_";"_STAG

 +11               QUIT 

               End DoDot:1

 +12       QUIT REC

 +13      ; 

SHOW(X)   ; DISPLAY THE LIST

 +1        NEW NAME,CODE,I,Y,STOP

 +2        FOR I=1:1:$LENGTH(X,U)

               Begin DoDot:1

 +3                WRITE !

 +4                IF '(I#20)

                       IF '$$WAIT^VENPCCU

                           SET STOP=1

                           QUIT 

 +5                SET Y=$PIECE(X,U,I)

 +6                IF Y=""

                       IF I=1

                           WRITE "No entries found!"

                       SET STOP=1

                       QUIT 

 +7                SET NAME=$PIECE(Y,";")

                   SET CODE=$PIECE(Y,";",2)

 +8                WRITE I,?5,NAME," ",CODE

 +9                QUIT 

               End DoDot:1

               IF $GET(STOP)

                   QUIT 

 +10       QUIT 

 +11      ; 

ADD(LIST,STAT) ; ADD AN ENTRY

 +1        NEW DIRUT,DUOUT,DTOUT,X,Y,%,DIC,POS,NAME,CODE,DIROUT

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,DIROUT,DUOUT

           QUIT LIST

CODE      ; 

 +1        SET CODE=""

           SET DIR(0)="FO^1:6"

           SET DIR("A")="CPT 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

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)="NO^1:"_$PIECE(STAT,U,2)_":"

           SET DIR("A")="Delete entry from what position"

           KILL DA

           DO ^DIR

           KILL DIR

 +1        IF '+Y

               QUIT LIST

 +2        SET POS=+Y

 +3        WRITE !,"Sure you want to delete "_$PIECE($PIECE(LIST,U,POS),";")

 +4        SET %=1

           DO YN^DICN

           IF $DATA(DIRUT)!($DATA(DTOUT))

               QUIT LIST

 +5        IF %'=1

               GOTO DEL2

 +6        IF POS=$PIECE(STAT,U,2)

               SET LIST=$PIECE(LIST,U,1,POS-1)

               GOTO DEL3

 +7        IF POS=1

               SET LIST=$PIECE(LIST,U,2,99)

               GOTO DEL3

 +8        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 !

           DO SHOW(LIST)

           WRITE !

 +2        WRITE !!,"Want to delete another entry"

           SET %=1

 +3        DO YN^DICN

           IF %'=1

               QUIT LIST

 +4        GOTO DEL1

 +5       ; 

COPY(LIST,STAT,TITLE,EF,CPT) ; COPY IN ANOTHER LIST

 +1        NEW PGRP,CTITLE,CLIST,DUOUT,DIRUT,DTOUT,I

 +2        WRITE !!,"Define the Patient Group to copy from =>"

 +3        SET PGRP=$$PGRP

           IF PGRP=""

               QUIT LIST

 +4        SET CLIST=$$LIST(+EF,+CPT,PGRP)

           IF CLIST=""

               WRITE !,"Unable to copy because no entries found!"

               HANG 3

               QUIT LIST

 +5        SET CTITLE=$$TITLE(EF,CPT,PGRP)

 +6        WRITE !,CTITLE

 +7        WRITE !

           DO SHOW(CLIST)

 +8        WRITE !,"OK to copy non-redundant entries from this list"

 +9        SET %=1

           DO YN^DICN

           IF %'=1

               QUIT LIST

 +10       FOR I=1:1:$LENGTH(CLIST,U)