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)
SET X=$PIECE(CLIST,U,I)
IF LIST'[X
IF LIST'=""
SET LIST=LIST_U
SET LIST=LIST_X
+11 WRITE !!,"Source list: ",TITLE
+12 WRITE !
DO SHOW(LIST)
+13 QUIT LIST
+14 ;
SUB(LIST,EF,CPT,PGRP) ; EP-FOR SUBMITTING AN EXTERNALY GENERATED LIST
+1 NEW EFLAG
SET EFLAG=1
+2 GOTO S1
+3 ;
SUBMIT(LIST,EF,CPT,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)-$$MAX(+EF,+CPT)
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 DO SHOW(LIST)
+5 WRITE !,"Are you sure everything is OK"
+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"
+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,CPT,PGRP)
QUIT 1
+1 IF Y="C"
SET LIST=$$ALPH(LIST,2)
DO SAVE(LIST,EF,CPT,PGRP)
QUIT 1
+2 IF Y="S"
DO SAVE(LIST,EF,CPT,PGRP)
QUIT 1
+3 QUIT 0
+4 ;
ALPH(LIST,PCE) ; 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,CPT,PGRP) ; EP-DELETE THE OLD LIST AND SAVE THE NEW ONE
+1 IF $DATA(^VEN(7.41,+$GET(EF),0))
IF $DATA(^VEN(7.98,+$GET(CPT),0))
IF $LENGTH(LIST)
IF PGRP
IF PGRP=PGRP\1
IF PGRP>0
IF PGRP<5
+2 IF '$TEST
QUIT
+3 NEW 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
+4 SET DIK="^VEN(7.93,"
+5 SET MN=$PIECE($GET(^VEN(7.98,+CPT,0)),U,3)
+6 SET IX=PGRP_MN
+7 SET DA=0
FOR
SET DA=$ORDER(^VEN(7.93,"AC",IX,DA))
IF 'DA
QUIT
DO ^DIK
+8 SET DIC=DIK
SET DIC(0)="L"
SET DIE=DIC
SET DLAYGO=19707.93
+9 FOR PCE=1:1:$LENGTH(LIST,U)
Begin DoDot:1
+10 SET %=$PIECE(LIST,U,PCE)
+11 SET CODE=$PIECE(%,";",2)
SET CTAG=$PIECE(%,";",3)
SET STAG=$PIECE(%,";",4)
+12 SET X=""""_$PIECE(%,";")_""""
SET HDR=MN_PCE
+13 SET HIEN=$ORDER(^VEN(7.42,"B",HDR,0))
IF 'HIEN
QUIT
+14 DO ^DIC
IF Y=-1
QUIT
+15 SET DA=+Y
SET DR=".02////"_$PIECE($GET(^VEN(7.41,+$GET(EF),0)),U,9)_";.03////"_HIEN_";.06////"_CODE_";.09////"_+PGRP_";.11////"_+EF_";1////"_$TRANSLATE(CTAG,"|",U)_";2////"_$TRANSLATE(STAG,"|",U)
+16 LOCK +^VEN(7.93,DA):5
IF '$TEST
QUIT
+17 DO ^DIE
LOCK -^VEN(7.93,DA)
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
EN1 ; EP FOR LOOPING THROUGH ALL CPT & PATIENT GROUPS IN A TEMPLATE
+1 NEW LOOP
SET LOOP=1
+2 GOTO NEW
+3 QUIT
+4 ;
NEXT(EF,CPT,PGRP) ;
+1 NEW CIEN,NAME
+2 IF EF=""
SET EF=$$EF("")
IF '$LENGTH(EF)
QUIT 0
+3 SET PGRP=PGRP+1
IF PGRP=5
SET PGRP=1
+4 IF PGRP>1
QUIT EF_";"_CPT_";"_PGRP
N1 SET CIEN=$ORDER(^VEN(7.98,+CPT))
SET NAME=$PIECE($GET(^VEN(7.98,+CIEN,0)),U)
SET CPT=CIEN_U_NAME
+1 IF 'CPT
WRITE !!,"You have successfully edited this template!"
QUIT 0
+2 IF NAME="HEALTH MAINTENANCE REMINDERS"
GOTO N1
+3 IF NAME="PHYSICAL EXAM"
GOTO N1
+4 QUIT EF_";"_CPT_";"_PGRP
+5 ;
MAX(EF,CPT) ; EP-MAX ITEMS
+1 NEW MN,X,I,Y,SS,PCE,MAX
+2 SET MN=$PIECE($GET(^VEN(7.98,CPT,0)),U,2)
+3 IF '$LENGTH(MN)
QUIT ""
+4 SET 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"
+5 FOR I=1:1:$LENGTH(X,U)
SET Y=$PIECE(X,U,I)
IF $PIECE(Y,";")=MN
SET SS=$PIECE(Y,";",2)
SET PCE=$PIECE(Y,";",3)
QUIT
+6 IF '$GET(PCE)
QUIT ""
+7 SET MAX=$PIECE($GET(^VEN(7.41,EF,SS)),U,PCE)
+8 QUIT MAX
+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")="CPT 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 ;
