VENPCCC1 ; IHS/OIT/GIS - CHECK LIST EDITING AND VIEWING ;
;;2.6;PCC+;;NOV 12, 2007
;
;
;
AIC ; EP-ATTACH AN ITEM TO A CHECKLIST
N IIEN,DIC,LIEN,DA,X,Y
W !,"Select an ITEM to assign to a checklist ->"
S IIEN=$$SI I 'IIEN Q
D ATI(IIEN)
S DIC="^VEN(7.9,",DIC(0)="AEQL",DLAYGO=19707.9
S DIC("A")="Select a CHECKLIST: "
D ^DIC I Y=-1 Q
S LIEN=+Y
I $D(^VEN(7.91,IIEN,2,"B",LIEN)) W !,"This item is already in this checklist. Try again..." Q
S DA(1)=IIEN S DIC="^VEN(7.91,"_DA(1)_",2,"
S DIC("P")="19707.912P" S DIC(0)="L",DLAYGO=19707.912
S X="`"_LIEN
D ^DIC
W !,"OK, this item will now appear on the checklist!"
D ^XBFMK
Q
;
DIC ; EP-DELETE AN ITEM FROM A CHECKLIST
N DIK,DA,X,Y,%,IIEN,DICS,LIEN,STG,CNT,ARR,CNAME,PCE,CKIEN
W !,"Select the ITEM to be deleted ->"
N %
S %=$$SI I '% Q
D AT(%)
S IIEN=% S STG="" S LIEN=0
F S LIEN=$O(^VEN(7.91,IIEN,2,"B",LIEN)) Q:'LIEN S STG=STG_LIEN_"|"_$O(^VEN(7.91,IIEN,2,"B",LIEN,0))_U
I '$L(STG) W !,"This item is not currently assigned to any checklists!" Q
I $L(STG,U)=2 D Q ; IF THERE IS ONLY ONE CHECKLIST
. S %=$P(STG,U) I '$L(%) Q
. S LIEN=+% I 'LIEN Q
. S CKIEN=$P(%,"|",2) I 'CKIEN Q
. S CNAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(CNAME) Q
. W !,"This item is currently assigned to the "_CNAME_" checklist",!,"Sure you want to delete it"
. S %="" D YN^DICN I %'=1 Q
. S DA=$O(^VEN(7.91,IIEN,2,"B",LIEN,0)) I 'DA Q ; PATCHED BY GIS/OIT 1/15/06 ; PCC+ 2.5 PATCH 2
. D DICD
. Q
W !,"This item is currently assigned to the following checklists ->" ; MULTIPLE CHECKLISTS
S CNT=0
F PCE=1:1:($L(STG,U)-1) S %=$P(STG,U,PCE) I $L(%) D
. S LIEN=+% I 'LIEN Q
. S CKIEN=$P(%,"|",2) I 'CKIEN Q
. S CNAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(CNAME) Q
. S CNT=CNT+1
. S ARR(CNT)=CKIEN
. W !?3,CNT,?6,CNAME
. Q
S DIR("A")="The item will be deleted from which checklist"
S DIR(0)="N^1:"_CNT_":0" D ^DIR
I $G(DUOUT)!($G(DTOUT)) G DICX
I 'Y G DICX
S DA=$G(ARR(Y)) I 'DA G DICX
DICD S DA(1)=IIEN S DIK="^VEN(7.91,"_DA(1)_",2," ; DELETE THE SUBFILE ENTRY
D ^DIK
W !,"OK, this item has been removed from the checklist..."
DICX D ^XBFMK ; CLEANUP
Q
;
ACT ; EP-ASSIGN A CHECKLIST TO A TEMPLATE
W !,"Select a checklist to assign to a PCC+ template ->"
N LIEN,DA,DIC,X,Y,%,%Y
S LIEN=$$SC I 'LIEN Q
W ! D AT(LIEN,1)
W !
S DIC("A")="Assign this checklist to what PCC+ template: "
S DIC="^VEN(7.41,",DIC(0)="AEQL",DLAYGO=19707.41
D ^DIC I Y=-1 Q
I $D(^VEN(7.41,+Y,17,"B",LIEN)) W !,"This checklist is already on the template! Request cancelled..." D ^XBFMK Q
W !,"Are you sure" S %="" D YN^DICN I %'=1 Q
S DA(1)=+Y
S DIC="^VEN(7.41,"_DA(1)_",17,",DIC(0)="L"
S DIC("P")="19707.4117P",DLAYGO=19707.4117
S X="`"_LIEN
D ^DIC I Y=-1 Q
D ^XBFMK
W !,"OK, this checklist will now appear on the template!"
Q
;
DCT ; EP-DELETE A CHECKLIST FROM A PCC+ TEMPLATE
N DIC,X,Y,DA,CNAME,CKIEN,LIEN,TNAME
S DIC("A")="PCC+ Template: "
S DIC="^VEN(7.41,",DIC(0)="AEQM"
D ^DIC I Y=-1 G DCTX
S DA(1)=+Y S TNAME=$P(Y,U,2)
S DIC="^VEN(7.41,"_DA(1)_",17,",DIC(0)="AEQM"
S DIC("A")="Which CHECKLIST do you want to delete: "
D ^DIC I Y=-1 G DCTX
S CKIEN=+Y I 'CKIEN Q
S LIEN=$P($G(^VEN(7.41,DA(1),17,CKIEN,0)),U) I 'LIEN Q
S CNAME=$P($G(^VEN(7.9,LIEN,0)),U)
W !!,"The ",CNAME," checklist has been deleted from",!,"the ",TNAME," template..."
DCTX D ^XBFMK
Q
;
VI ; EP-VIEW AN ITEM
N %
S %=$$SI I '% Q
D ATI(%)
Q
;
VC ; EP-VIEW CHECLIST PROPERTIES
N %
S %=$$SC I '% Q
D AT(%,1)
Q
;
AC ; EP-ADD A CHECKLIST
N DA,DIR,DIC,DIE,DR,%,NAME,OGIEN,PMN,X,Y
AC1 S DIR(0)="FO^1:25",DIR("A")="Name of new CHECKLIST"
D ^DIR
I X?1."^"!(X="") G ACFIN
I $G(DIRUT)!($G(DTOUT)) G ACFIN
I $D(^VEN(7.9,"B",X)) W !,"This name has already been used. Try again..." G AC1
S NAME=X
S DIC="^VEN(7.98,",DIC(0)="AEQM",DIC("A")="Checklist content: "
D ^DIC I Y=-1 Q
S OGIEN=+Y
S PMN=$P($G(^VEN(7.98,OGIEN,0)),U,2) I '$L(PMN) Q
S %=(" ("_PMN_")") I NAME'[% S NAME=NAME_%
I $D(^VEN(7.9,"B",NAME)) W !,"The name '"_NAME_"' has already been used." W !,"Try again..." G AC1
S DIC="^VEN(7.9,",DIC(0)="L",DLAYGO=19707.9,X=NAME
D ^DIC I Y=-1 Q
S DIE=DIC,DA=+Y,DR=".02////^S X=OGIEN;.03;.04"
D ^DIE
W !,"OK, "_NAME_" has been added as a new checklist..."
ACFIN D ^XBFMK
Q
;
GCPT ; EP-GLOBAL EDIT OF CPT CODE
N DIR,DA,%,%Y,IIEN,C1,C2,X
S DIR(0)="F^1:9",DIR("A")="Change code from" S DIR("?")="Enter the CPT code to be changed."
D ^DIR
I $G(DUOUT)!$G(DTOUT) G GCPTX
I '$L(Y) G GCPTX
S FROM=Y
S DIR(0)="F^1:9",DIR("A")="Change code to" S DIR("?")="Enter the new CPT code."
D ^DIR
I $G(DUOUT)!$G(DTOUT) G GCPTX
I '$L(Y) G GCPTX
S TO=Y
W !,"Sure you want to change every instance of a CPT code from ",FROM," to ",TO
S %="" D YN^DICN
I %'=1 G GCPTX
S IIEN=0
F S IIEN=$O(^VEN(7.91,IIEN)) Q:'IIEN D ; GLOBAL SUBSTITUTION
. S X=$G(^VEN(7.91,IIEN,0)) I '$L(X) Q
. S Y=0
. S C1=$P(X,U,7) I C1=FROM S $P(X,U,7)=TO,Y=1
. S C2=$P(X,U,8) I C2=FROM S $P(X,U,8)=TO,Y=1
. I 'Y Q
. S ^VEN(7.91,IIEN,0)=X
. W !,"The code for ",$P(X,U)," has been changed!"
. Q
GCPTX D ^XBFMK
Q
;
AI ;EP- ADD AN ITEM
N DIC,DIE,DA,DR,X,Y
S DIC="^VEN(7.91," S DLAYGO=19707.91
S DIE=DIC S DIC(0)="AEQMLX"
S DIC("A")="Name of NEW ITEM: "
D ^DIC I Y=-1 Q
S DA=+Y
S DR=".03:.1"
D ^DIE
D ^XBFMK K DDER
Q
;
DI ; EP-DELETE AN ITEM
N IIEN,DIK,DA,%,%Y
W !!,"Select an item to DELETE ->"
S IIEN=$$IASK I 'IIEN Q
D ATI(IIEN)
W !!,"Are you sure you want to DELETE this item"
S %="" D YN^DICN I %'=1 Q
S DIK="^VEN(7.91,",DA=IIEN
D ^DIK
D ^XBFMK
Q
;
EI ; EP-EDIT AN ITEM
N IIEN,DIE,DR,DA,X,Y
W !!,"Select an item to EDIT ->"
S IIEN=$$IASK I 'IIEN Q
D ATI(IIEN)
S DIE="^VEN(7.91,",DA=IIEN
S DR=".01;.03:.1"
D ^DIE
D ^XBFMK
Q
;
SC() ; EP-SELECT A CHECKLIST
N ARR,CNT,NAME,LIEN,OGIEN,MN,PCE,SEL,%
S CNT=0 S NAME=""
F S NAME=$O(^VEN(7.9,"B",NAME)) Q:NAME="" D
. S LIEN=$O(^VEN(7.9,"B",NAME,0)) I 'LIEN Q
. S %=$G(^VEN(7.9,LIEN,0)) I '$L(%) Q
. S OGIEN=$P(%,U,2) I 'OGIEN Q
. S PRE=$P(%,U,3) S POST=$P(%,U,4)
. S MN=$P($G(^VEN(7.98,OGIEN,0)),U,3) I MN="" Q
. S CNT=CNT+1
. S ARR(CNT)=CNT_"|0^"_NAME_"|4^"_MN_"|35^"_PRE_"|50^"_POST_"|60"
. S ARR(CNT,0)=LIEN
. Q
CLIST W !!,$E($T(CHDR),8,999),!,$E($T(CSEP),8,999)
G LIST
;
IASK(DICS) ; EP - ASK FOR AN ITEM
N DIC,X,Y
I $L($G(DICS)) S DIC("S")=DICS
S DIC="^VEN(7.91,",DIC(0)="AEQM"
S DIC("A")="Checklist ITEM: "
D ^DIC I Y=-1 Q ""
Q +Y
;
SI() ; EP - SELECT AN ITEM
N CNT,IIEN,X,Y,Z,%,NAME,GRP,CODE1,CODE2,PRE,POST,PCE,SEL,ARR,CFLG
S CNT=0,NAME="",CFLG=1
F S NAME=$O(^VEN(7.91,"B",NAME)) Q:NAME="" D ; MAKE DISPLAAY ARRAY
. S IIEN=$O(^VEN(7.91,"B",NAME,0)) I 'IIEN Q
. S X=$G(^VEN(7.91,IIEN,0)) I '$L(X) Q
. S CNT=CNT+1
. S GRP=""
. I $P(X,U,3) S GRP=GRP_"I"
. I $P(X,U,4) S GRP=GRP_"C"
. I $P(X,U,5) S GRP=GRP_"M"
. I $P(X,U,6) S GRP=GRP_"W"
. S CODE1=$P(X,U,7)
. S CODE2=$P(X,U,8)
. S ARR(CNT)=CNT_"|0^"_NAME_"|4^"_GRP_"|34^"_CODE1_"|39^"_CODE2_"|49^"
. S ARR(CNT,0)=IIEN
. Q
ILIST W !!,$E($T(IHDR),8,999),!,$E($T(ISEP),8,999)
LIST S CNT=0 S SEL=""
F S CNT=$O(ARR(CNT)) Q:'CNT D I $L(SEL) Q
. W !
. I (CNT#16)=0 D I $L(SEL) Q
.. W "Enter 1-"_(CNT-1)_" or press <Enter> to see more: "
.. K % R %:$G(DTIME,60)
.. I $G(%)!(%?1."^") S SEL=% Q
.. W $C(13),?78,$C(13)
.. Q
. F PCE=1:1:$L(ARR(CNT),U) S X=$P(ARR(CNT),U,PCE) D
.. S Y=$P(X,"|"),Z=$P(X,"|",2)
.. W ?Z,Y
.. Q
. Q
I SEL="" W !,"Enter 1-"_$O(ARR(999),-1)_" or press '^' to quit: " R SEL:$G(DT,60) E Q ""
I SEL?1."^"!(SEL="") Q ""
I '$D(ARR(SEL)) W " ??" G ILIST
I $G(CFLG) W " (",$P($G(^VEN(7.91,ARR(SEL,0),0)),U),")" ; CONFIRM SELECTION
W !
Q ARR(SEL,0)
;
ATI(IIEN) ; EP-ASSOCIATED TEMPLATES FOR ITEMS
I '$O(^VEN(7.91,+$G(IIEN),2,0)) W !,"This item is not associated with any checklists or templates!" Q
N CKIEN,LIEN
W !,"This item is associated with the following checklists and PCC+ templates: "
S CKIEN=0 F S CKIEN=$O(^VEN(7.91,IIEN,2,CKIEN)) Q:'CKIEN D
. S LIEN=$P($G(^VEN(7.91,IIEN,2,CKIEN,0)),U) I 'LIEN Q
. D AT(LIEN)
. Q
Q
;
AT(LIEN,MODE) ; EP-LIST TEMPLATES ASSOCIATED WITH A CHECKLIST
N NAME,STG,TIEN,I,%,TAB
S MODE=+$G(MODE)
S TAB=3 I MODE S TAB=0
S NAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(NAME) Q
W !,?TAB W:MODE "PCC+ templates associated with " W NAME
S STG="",TIEN=0
S TAB=6 I MODE S TAB=3
F S TIEN=$O(^VEN(7.41,TIEN)) Q:'TIEN I $O(^VEN(7.41,TIEN,17,"B",LIEN,0)) S STG=STG_TIEN_U
I STG="" W !,?TAB,"No PCC+ templates are associated with this checklist!" Q
F I=1:1:($L(STG,U)-1) S TIEN=$P(STG,U,I) S %=$P($G(^VEN(7.41,TIEN,0)),U) I $L(%) W !,?TAB,%
Q
;
IHDR ; # ITEM GRP CODE1 CODE2
ISEP ; --- ----------------------------- ---- --------- ---------
CHDR ; # NAME MAIL MERGE FLD PRE POST
CSEP ; --- ------------------------------ -------------- --------- ---------
VENPCCC1 ; IHS/OIT/GIS - CHECK LIST EDITING AND VIEWING ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ;
+4 ;
AIC ; EP-ATTACH AN ITEM TO A CHECKLIST
+1 NEW IIEN,DIC,LIEN,DA,X,Y
+2 WRITE !,"Select an ITEM to assign to a checklist ->"
+3 SET IIEN=$$SI
IF 'IIEN
QUIT
+4 DO ATI(IIEN)
+5 SET DIC="^VEN(7.9,"
SET DIC(0)="AEQL"
SET DLAYGO=19707.9
+6 SET DIC("A")="Select a CHECKLIST: "
+7 DO ^DIC
IF Y=-1
QUIT
+8 SET LIEN=+Y
+9 IF $DATA(^VEN(7.91,IIEN,2,"B",LIEN))
WRITE !,"This item is already in this checklist. Try again..."
QUIT
+10 SET DA(1)=IIEN
SET DIC="^VEN(7.91,"_DA(1)_",2,"
+11 SET DIC("P")="19707.912P"
SET DIC(0)="L"
SET DLAYGO=19707.912
+12 SET X="`"_LIEN
+13 DO ^DIC
+14 WRITE !,"OK, this item will now appear on the checklist!"
+15 DO ^XBFMK
+16 QUIT
+17 ;
DIC ; EP-DELETE AN ITEM FROM A CHECKLIST
+1 NEW DIK,DA,X,Y,%,IIEN,DICS,LIEN,STG,CNT,ARR,CNAME,PCE,CKIEN
+2 WRITE !,"Select the ITEM to be deleted ->"
+3 NEW %
+4 SET %=$$SI
IF '%
QUIT
+5 DO AT(%)
+6 SET IIEN=%
SET STG=""
SET LIEN=0
+7 FOR
SET LIEN=$ORDER(^VEN(7.91,IIEN,2,"B",LIEN))
IF 'LIEN
QUIT
SET STG=STG_LIEN_"|"_$ORDER(^VEN(7.91,IIEN,2,"B",LIEN,0))_U
+8 IF '$LENGTH(STG)
WRITE !,"This item is not currently assigned to any checklists!"
QUIT
+9 ; IF THERE IS ONLY ONE CHECKLIST
IF $LENGTH(STG,U)=2
Begin DoDot:1
+10 SET %=$PIECE(STG,U)
IF '$LENGTH(%)
QUIT
+11 SET LIEN=+%
IF 'LIEN
QUIT
+12 SET CKIEN=$PIECE(%,"|",2)
IF 'CKIEN
QUIT
+13 SET CNAME=$PIECE($GET(^VEN(7.9,LIEN,0)),U)
IF '$LENGTH(CNAME)
QUIT
+14 WRITE !,"This item is currently assigned to the "_CNAME_" checklist",!,"Sure you want to delete it"
+15 SET %=""
DO YN^DICN
IF %'=1
QUIT
+16 ; PATCHED BY GIS/OIT 1/15/06 ; PCC+ 2.5 PATCH 2
SET DA=$ORDER(^VEN(7.91,IIEN,2,"B",LIEN,0))
IF 'DA
QUIT
+17 DO DICD
+18 QUIT
End DoDot:1
QUIT
+19 ; MULTIPLE CHECKLISTS
WRITE !,"This item is currently assigned to the following checklists ->"
+20 SET CNT=0
+21 FOR PCE=1:1:($LENGTH(STG,U)-1)
SET %=$PIECE(STG,U,PCE)
IF $LENGTH(%)
Begin DoDot:1
+22 SET LIEN=+%
IF 'LIEN
QUIT
+23 SET CKIEN=$PIECE(%,"|",2)
IF 'CKIEN
QUIT
+24 SET CNAME=$PIECE($GET(^VEN(7.9,LIEN,0)),U)
IF '$LENGTH(CNAME)
QUIT
+25 SET CNT=CNT+1
+26 SET ARR(CNT)=CKIEN
+27 WRITE !?3,CNT,?6,CNAME
+28 QUIT
End DoDot:1
+29 SET DIR("A")="The item will be deleted from which checklist"
+30 SET DIR(0)="N^1:"_CNT_":0"
DO ^DIR
+31 IF $GET(DUOUT)!($GET(DTOUT))
GOTO DICX
+32 IF 'Y
GOTO DICX
+33 SET DA=$GET(ARR(Y))
IF 'DA
GOTO DICX
DICD ; DELETE THE SUBFILE ENTRY
SET DA(1)=IIEN
SET DIK="^VEN(7.91,"_DA(1)_",2,"
+1 DO ^DIK
+2 WRITE !,"OK, this item has been removed from the checklist..."
DICX ; CLEANUP
DO ^XBFMK
+1 QUIT
+2 ;
ACT ; EP-ASSIGN A CHECKLIST TO A TEMPLATE
+1 WRITE !,"Select a checklist to assign to a PCC+ template ->"
+2 NEW LIEN,DA,DIC,X,Y,%,%Y
+3 SET LIEN=$$SC
IF 'LIEN
QUIT
+4 WRITE !
DO AT(LIEN,1)
+5 WRITE !
+6 SET DIC("A")="Assign this checklist to what PCC+ template: "
+7 SET DIC="^VEN(7.41,"
SET DIC(0)="AEQL"
SET DLAYGO=19707.41
+8 DO ^DIC
IF Y=-1
QUIT
+9 IF $DATA(^VEN(7.41,+Y,17,"B",LIEN))
WRITE !,"This checklist is already on the template! Request cancelled..."
DO ^XBFMK
QUIT
+10 WRITE !,"Are you sure"
SET %=""
DO YN^DICN
IF %'=1
QUIT
+11 SET DA(1)=+Y
+12 SET DIC="^VEN(7.41,"_DA(1)_",17,"
SET DIC(0)="L"
+13 SET DIC("P")="19707.4117P"
SET DLAYGO=19707.4117
+14 SET X="`"_LIEN
+15 DO ^DIC
IF Y=-1
QUIT
+16 DO ^XBFMK
+17 WRITE !,"OK, this checklist will now appear on the template!"
+18 QUIT
+19 ;
DCT ; EP-DELETE A CHECKLIST FROM A PCC+ TEMPLATE
+1 NEW DIC,X,Y,DA,CNAME,CKIEN,LIEN,TNAME
+2 SET DIC("A")="PCC+ Template: "
+3 SET DIC="^VEN(7.41,"
SET DIC(0)="AEQM"
+4 DO ^DIC
IF Y=-1
GOTO DCTX
+5 SET DA(1)=+Y
SET TNAME=$PIECE(Y,U,2)
+6 SET DIC="^VEN(7.41,"_DA(1)_",17,"
SET DIC(0)="AEQM"
+7 SET DIC("A")="Which CHECKLIST do you want to delete: "
+8 DO ^DIC
IF Y=-1
GOTO DCTX
+9 SET CKIEN=+Y
IF 'CKIEN
QUIT
+10 SET LIEN=$PIECE($GET(^VEN(7.41,DA(1),17,CKIEN,0)),U)
IF 'LIEN
QUIT
+11 SET CNAME=$PIECE($GET(^VEN(7.9,LIEN,0)),U)
+12 WRITE !!,"The ",CNAME," checklist has been deleted from",!,"the ",TNAME," template..."
DCTX DO ^XBFMK
+1 QUIT
+2 ;
VI ; EP-VIEW AN ITEM
+1 NEW %
+2 SET %=$$SI
IF '%
QUIT
+3 DO ATI(%)
+4 QUIT
+5 ;
VC ; EP-VIEW CHECLIST PROPERTIES
+1 NEW %
+2 SET %=$$SC
IF '%
QUIT
+3 DO AT(%,1)
+4 QUIT
+5 ;
AC ; EP-ADD A CHECKLIST
+1 NEW DA,DIR,DIC,DIE,DR,%,NAME,OGIEN,PMN,X,Y
AC1 SET DIR(0)="FO^1:25"
SET DIR("A")="Name of new CHECKLIST"
+1 DO ^DIR
+2 IF X?1."^"!(X="")
GOTO ACFIN
+3 IF $GET(DIRUT)!($GET(DTOUT))
GOTO ACFIN
+4 IF $DATA(^VEN(7.9,"B",X))
WRITE !,"This name has already been used. Try again..."
GOTO AC1
+5 SET NAME=X
+6 SET DIC="^VEN(7.98,"
SET DIC(0)="AEQM"
SET DIC("A")="Checklist content: "
+7 DO ^DIC
IF Y=-1
QUIT
+8 SET OGIEN=+Y
+9 SET PMN=$PIECE($GET(^VEN(7.98,OGIEN,0)),U,2)
IF '$LENGTH(PMN)
QUIT
+10 SET %=(" ("_PMN_")")
IF NAME'[%
SET NAME=NAME_%
+11 IF $DATA(^VEN(7.9,"B",NAME))
WRITE !,"The name '"_NAME_"' has already been used."
WRITE !,"Try again..."
GOTO AC1
+12 SET DIC="^VEN(7.9,"
SET DIC(0)="L"
SET DLAYGO=19707.9
SET X=NAME
+13 DO ^DIC
IF Y=-1
QUIT
+14 SET DIE=DIC
SET DA=+Y
SET DR=".02////^S X=OGIEN;.03;.04"
+15 DO ^DIE
+16 WRITE !,"OK, "_NAME_" has been added as a new checklist..."
ACFIN DO ^XBFMK
+1 QUIT
+2 ;
GCPT ; EP-GLOBAL EDIT OF CPT CODE
+1 NEW DIR,DA,%,%Y,IIEN,C1,C2,X
+2 SET DIR(0)="F^1:9"
SET DIR("A")="Change code from"
SET DIR("?")="Enter the CPT code to be changed."
+3 DO ^DIR
+4 IF $GET(DUOUT)!$GET(DTOUT)
GOTO GCPTX
+5 IF '$LENGTH(Y)
GOTO GCPTX
+6 SET FROM=Y
+7 SET DIR(0)="F^1:9"
SET DIR("A")="Change code to"
SET DIR("?")="Enter the new CPT code."
+8 DO ^DIR
+9 IF $GET(DUOUT)!$GET(DTOUT)
GOTO GCPTX
+10 IF '$LENGTH(Y)
GOTO GCPTX
+11 SET TO=Y
+12 WRITE !,"Sure you want to change every instance of a CPT code from ",FROM," to ",TO
+13 SET %=""
DO YN^DICN
+14 IF %'=1
GOTO GCPTX
+15 SET IIEN=0
+16 ; GLOBAL SUBSTITUTION
FOR
SET IIEN=$ORDER(^VEN(7.91,IIEN))
IF 'IIEN
QUIT
Begin DoDot:1
+17 SET X=$GET(^VEN(7.91,IIEN,0))
IF '$LENGTH(X)
QUIT
+18 SET Y=0
+19 SET C1=$PIECE(X,U,7)
IF C1=FROM
SET $PIECE(X,U,7)=TO
SET Y=1
+20 SET C2=$PIECE(X,U,8)
IF C2=FROM
SET $PIECE(X,U,8)=TO
SET Y=1
+21 IF 'Y
QUIT
+22 SET ^VEN(7.91,IIEN,0)=X
+23 WRITE !,"The code for ",$PIECE(X,U)," has been changed!"
+24 QUIT
End DoDot:1
GCPTX DO ^XBFMK
+1 QUIT
+2 ;
AI ;EP- ADD AN ITEM
+1 NEW DIC,DIE,DA,DR,X,Y
+2 SET DIC="^VEN(7.91,"
SET DLAYGO=19707.91
+3 SET DIE=DIC
SET DIC(0)="AEQMLX"
+4 SET DIC("A")="Name of NEW ITEM: "
+5 DO ^DIC
IF Y=-1
QUIT
+6 SET DA=+Y
+7 SET DR=".03:.1"
+8 DO ^DIE
+9 DO ^XBFMK
KILL DDER
+10 QUIT
+11 ;
DI ; EP-DELETE AN ITEM
+1 NEW IIEN,DIK,DA,%,%Y
+2 WRITE !!,"Select an item to DELETE ->"
+3 SET IIEN=$$IASK
IF 'IIEN
QUIT
+4 DO ATI(IIEN)
+5 WRITE !!,"Are you sure you want to DELETE this item"
+6 SET %=""
DO YN^DICN
IF %'=1
QUIT
+7 SET DIK="^VEN(7.91,"
SET DA=IIEN
+8 DO ^DIK
+9 DO ^XBFMK
+10 QUIT
+11 ;
EI ; EP-EDIT AN ITEM
+1 NEW IIEN,DIE,DR,DA,X,Y
+2 WRITE !!,"Select an item to EDIT ->"
+3 SET IIEN=$$IASK
IF 'IIEN
QUIT
+4 DO ATI(IIEN)
+5 SET DIE="^VEN(7.91,"
SET DA=IIEN
+6 SET DR=".01;.03:.1"
+7 DO ^DIE
+8 DO ^XBFMK
+9 QUIT
+10 ;
SC() ; EP-SELECT A CHECKLIST
+1 NEW ARR,CNT,NAME,LIEN,OGIEN,MN,PCE,SEL,%
+2 SET CNT=0
SET NAME=""
+3 FOR
SET NAME=$ORDER(^VEN(7.9,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+4 SET LIEN=$ORDER(^VEN(7.9,"B",NAME,0))
IF 'LIEN
QUIT
+5 SET %=$GET(^VEN(7.9,LIEN,0))
IF '$LENGTH(%)
QUIT
+6 SET OGIEN=$PIECE(%,U,2)
IF 'OGIEN
QUIT
+7 SET PRE=$PIECE(%,U,3)
SET POST=$PIECE(%,U,4)
+8 SET MN=$PIECE($GET(^VEN(7.98,OGIEN,0)),U,3)
IF MN=""
QUIT
+9 SET CNT=CNT+1
+10 SET ARR(CNT)=CNT_"|0^"_NAME_"|4^"_MN_"|35^"_PRE_"|50^"_POST_"|60"
+11 SET ARR(CNT,0)=LIEN
+12 QUIT
End DoDot:1
CLIST WRITE !!,$EXTRACT($TEXT(CHDR),8,999),!,$EXTRACT($TEXT(CSEP),8,999)
+1 GOTO LIST
+2 ;
IASK(DICS) ; EP - ASK FOR AN ITEM
+1 NEW DIC,X,Y
+2 IF $LENGTH($GET(DICS))
SET DIC("S")=DICS
+3 SET DIC="^VEN(7.91,"
SET DIC(0)="AEQM"
+4 SET DIC("A")="Checklist ITEM: "
+5 DO ^DIC
IF Y=-1
QUIT ""
+6 QUIT +Y
+7 ;
SI() ; EP - SELECT AN ITEM
+1 NEW CNT,IIEN,X,Y,Z,%,NAME,GRP,CODE1,CODE2,PRE,POST,PCE,SEL,ARR,CFLG
+2 SET CNT=0
SET NAME=""
SET CFLG=1
+3 ; MAKE DISPLAAY ARRAY
FOR
SET NAME=$ORDER(^VEN(7.91,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+4 SET IIEN=$ORDER(^VEN(7.91,"B",NAME,0))
IF 'IIEN
QUIT
+5 SET X=$GET(^VEN(7.91,IIEN,0))
IF '$LENGTH(X)
QUIT
+6 SET CNT=CNT+1
+7 SET GRP=""
+8 IF $PIECE(X,U,3)
SET GRP=GRP_"I"
+9 IF $PIECE(X,U,4)
SET GRP=GRP_"C"
+10 IF $PIECE(X,U,5)
SET GRP=GRP_"M"
+11 IF $PIECE(X,U,6)
SET GRP=GRP_"W"
+12 SET CODE1=$PIECE(X,U,7)
+13 SET CODE2=$PIECE(X,U,8)
+14 SET ARR(CNT)=CNT_"|0^"_NAME_"|4^"_GRP_"|34^"_CODE1_"|39^"_CODE2_"|49^"
+15 SET ARR(CNT,0)=IIEN
+16 QUIT
End DoDot:1
ILIST WRITE !!,$EXTRACT($TEXT(IHDR),8,999),!,$EXTRACT($TEXT(ISEP),8,999)
LIST SET CNT=0
SET SEL=""
+1 FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+2 WRITE !
+3 IF (CNT#16)=0
Begin DoDot:2
+4 WRITE "Enter 1-"_(CNT-1)_" or press <Enter> to see more: "
+5 KILL %
READ %:$GET(DTIME,60)
+6 IF $GET(%)!(%?1."^")
SET SEL=%
QUIT
+7 WRITE $CHAR(13),?78,$CHAR(13)
+8 QUIT
End DoDot:2
IF $LENGTH(SEL)
QUIT
+9 FOR PCE=1:1:$LENGTH(ARR(CNT),U)
SET X=$PIECE(ARR(CNT),U,PCE)
Begin DoDot:2
+10 SET Y=$PIECE(X,"|")
SET Z=$PIECE(X,"|",2)
+11 WRITE ?Z,Y
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
IF $LENGTH(SEL)
QUIT
+14 IF SEL=""
WRITE !,"Enter 1-"_$ORDER(ARR(999),-1)_" or press '^' to quit: "
READ SEL:$GET(DT,60)
IF '$TEST
QUIT ""
+15 IF SEL?1."^"!(SEL="")
QUIT ""
+16 IF '$DATA(ARR(SEL))
WRITE " ??"
GOTO ILIST
+17 ; CONFIRM SELECTION
IF $GET(CFLG)
WRITE " (",$PIECE($GET(^VEN(7.91,ARR(SEL,0),0)),U),")"
+18 WRITE !
+19 QUIT ARR(SEL,0)
+20 ;
ATI(IIEN) ; EP-ASSOCIATED TEMPLATES FOR ITEMS
+1 IF '$ORDER(^VEN(7.91,+$GET(IIEN),2,0))
WRITE !,"This item is not associated with any checklists or templates!"
QUIT
+2 NEW CKIEN,LIEN
+3 WRITE !,"This item is associated with the following checklists and PCC+ templates: "
+4 SET CKIEN=0
FOR
SET CKIEN=$ORDER(^VEN(7.91,IIEN,2,CKIEN))
IF 'CKIEN
QUIT
Begin DoDot:1
+5 SET LIEN=$PIECE($GET(^VEN(7.91,IIEN,2,CKIEN,0)),U)
IF 'LIEN
QUIT
+6 DO AT(LIEN)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
AT(LIEN,MODE) ; EP-LIST TEMPLATES ASSOCIATED WITH A CHECKLIST
+1 NEW NAME,STG,TIEN,I,%,TAB
+2 SET MODE=+$GET(MODE)
+3 SET TAB=3
IF MODE
SET TAB=0
+4 SET NAME=$PIECE($GET(^VEN(7.9,LIEN,0)),U)
IF '$LENGTH(NAME)
QUIT
+5 WRITE !,?TAB
IF MODE
WRITE "PCC+ templates associated with "
WRITE NAME
+6 SET STG=""
SET TIEN=0
+7 SET TAB=6
IF MODE
SET TAB=3
+8 FOR
SET TIEN=$ORDER(^VEN(7.41,TIEN))
IF 'TIEN
QUIT
IF $ORDER(^VEN(7.41,TIEN,17,"B",LIEN,0))
SET STG=STG_TIEN_U
+9 IF STG=""
WRITE !,?TAB,"No PCC+ templates are associated with this checklist!"
QUIT
+10 FOR I=1:1:($LENGTH(STG,U)-1)
SET TIEN=$PIECE(STG,U,I)
SET %=$PIECE($GET(^VEN(7.41,TIEN,0)),U)
IF $LENGTH(%)
WRITE !,?TAB,%
+11 QUIT
+12 ;
IHDR ; # ITEM GRP CODE1 CODE2
ISEP ; --- ----------------------------- ---- --------- ---------
CHDR ; # NAME MAIL MERGE FLD PRE POST
CSEP ; --- ------------------------------ -------------- --------- ---------
