57 lines
2.2 KiB
Mathematica
57 lines
2.2 KiB
Mathematica
QACCODE ;HISC/CEW - Enter/Edit a Local Contact Issue Code ;1/30/95 09:02
|
|
;;2.0;Patient Representative;**3**;07/25/1995
|
|
;*********Variable List*********************************
|
|
;ALPHCODE =The major heading (ALPHA) code
|
|
;QASPECT =The IEN of the Quality Aspect
|
|
;NEXNUM =Next free number
|
|
;NUM =The last code number
|
|
;NEWIEN =The IEN of the new code
|
|
;QACIEN =The IEN of the Issue
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; This option no longer in use, as Issue Codes can no longer be
|
|
; entered or edited
|
|
W !!?5,"Issue Codes can no longer be entered or edited."
|
|
W !?5,"Only National Issue Codes are valid."
|
|
W !?5,"The Issue Code list will be periodically evaluated and updated."
|
|
Q
|
|
SLCHEAD ;
|
|
;Selects code to edit code text and status or a major heading
|
|
;under which a new code will reside.
|
|
W ! K DIC S DIC="^QA(745.2,",DIC(0)="AEQZ"
|
|
S DIC("A")="Select ISSUE CODE: "
|
|
S DIC("S")="I ($P(^(0),U,5)'=""N""!($P(^(0),U,2)=1)),($P(^(0),U,1)?2U.N)"
|
|
D ^DIC K DIC G:Y'>0 EXIT
|
|
S ALPHCODE=Y(0,0),NUM=99,QASPECT=$P(Y(0),"^",4),QACIEN=+Y
|
|
;Find out if selection is a major code (ALPHA only) heading
|
|
;to ENTER a new code text or else a numbered code for EDITing.
|
|
I $P(Y(0),U,2)="1" S FLAG=0 D ENTER G SLCHEAD
|
|
E D EDIT G SLCHEAD
|
|
ENTER ;Enter a new code text. Code number is built in background.
|
|
F S NUM=$O(^QA(745.2,"AH",ALPHCODE,NUM)) D Q:FLAG=1
|
|
.I NUM'>200 S NEXNUM=ALPHCODE_"201" S FLAG=1 Q
|
|
.S NEXNUM=ALPHCODE_(NUM+1)
|
|
.I '$D(^QA(745.2,"B",NEXNUM)) S FLAG=1
|
|
.Q
|
|
I $E(NEXNUM,2,4)>999 W !,"Only 999 issue codes allowed per heading! Select a different heading." G SLCHEAD
|
|
K DIR S DIR("A")="Are you adding '"_NEXNUM_"' as a new Contact Issue Code",DIR("0")="Y",DIR("B")="YES"
|
|
D ^DIR K DIR Q:($D(DIRUT))!(Y=0)
|
|
S DIC(0)="EMQLZ",DIC="^QA(745.2,",X=NEXNUM
|
|
D FILE^DICN G EXIT:Y<1 K DIC
|
|
S NEWIEN=+Y
|
|
L +^QA(745.2,NEWIEN):0 I '$T W "Try again later." G SLCHEAD
|
|
K DIE S DIE="^QA(745.2,",DA=NEWIEN,DR="1////0;3////"_QASPECT_";4////L;2;5"
|
|
D ^DIE K DIE L -^QA(745.2,NEWIEN)
|
|
Q
|
|
EDIT ;Edit an existing code text.
|
|
L +^QA(745.2,QACIEN):0 I '$T W "Try again later." G SLCHEAD
|
|
K DIE S DIE="^QA(745.2,",DA=QACIEN,DR="2;4;5"
|
|
D ^DIE K DIE L -^QA(745.2,QACIEN)
|
|
Q
|
|
EXIT ;
|
|
K DIC,DIE,QACIEN,ALPHCODE,NEXNUM,NEWIEN,NUM,Y,X,FLAG
|
|
K DA,DIRUT,DR,QASPECT
|
|
Q
|