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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQACCODE 2306 printed Jan 14, 2021@17:15:39 Page 2
QACCODE ;HISC/CEW - Enter/Edit a Local Contact Issue Code ;1/30/95 09:02
+1 ;;2.0;Patient Representative;**3**;07/25/1995
+2 ;*********Variable List*********************************
+3 ;ALPHCODE =The major heading (ALPHA) code
+4 ;QASPECT =The IEN of the Quality Aspect
+5 ;NEXNUM =Next free number
+6 ;NUM =The last code number
+7 ;NEWIEN =The IEN of the new code
+8 ;QACIEN =The IEN of the Issue
+9 ;
+10 ;
+11 ;
+12 ;
+13 ; This option no longer in use, as Issue Codes can no longer be
+14 ; entered or edited
+15 WRITE !!?5,"Issue Codes can no longer be entered or edited."
+16 WRITE !?5,"Only National Issue Codes are valid."
+17 WRITE !?5,"The Issue Code list will be periodically evaluated and updated."
+18 QUIT
SLCHEAD ;
+1 ;Selects code to edit code text and status or a major heading
+2 ;under which a new code will reside.
+3 WRITE !
KILL DIC
SET DIC="^QA(745.2,"
SET DIC(0)="AEQZ"
+4 SET DIC("A")="Select ISSUE CODE: "
+5 SET DIC("S")="I ($P(^(0),U,5)'=""N""!($P(^(0),U,2)=1)),($P(^(0),U,1)?2U.N)"
+6 DO ^DIC
KILL DIC
if Y'>0
GOTO EXIT
+7 SET ALPHCODE=Y(0,0)
SET NUM=99
SET QASPECT=$PIECE(Y(0),"^",4)
SET QACIEN=+Y
+8 ;Find out if selection is a major code (ALPHA only) heading
+9 ;to ENTER a new code text or else a numbered code for EDITing.
+10 IF $PIECE(Y(0),U,2)="1"
SET FLAG=0
DO ENTER
GOTO SLCHEAD
+11 IF '$TEST
DO EDIT
GOTO SLCHEAD
ENTER ;Enter a new code text. Code number is built in background.
+1 FOR
SET NUM=$ORDER(^QA(745.2,"AH",ALPHCODE,NUM))
Begin DoDot:1
+2 IF NUM'>200
SET NEXNUM=ALPHCODE_"201"
SET FLAG=1
QUIT
+3 SET NEXNUM=ALPHCODE_(NUM+1)
+4 IF '$DATA(^QA(745.2,"B",NEXNUM))
SET FLAG=1
+5 QUIT
End DoDot:1
if FLAG=1
QUIT
+6 IF $EXTRACT(NEXNUM,2,4)>999
WRITE !,"Only 999 issue codes allowed per heading! Select a different heading."
GOTO SLCHEAD
+7 KILL DIR
SET DIR("A")="Are you adding '"_NEXNUM_"' as a new Contact Issue Code"
SET DIR("0")="Y"
SET DIR("B")="YES"
+8 DO ^DIR
KILL DIR
if ($DATA(DIRUT))!(Y=0)
QUIT
+9 SET DIC(0)="EMQLZ"
SET DIC="^QA(745.2,"
SET X=NEXNUM
+10 DO FILE^DICN
if Y<1
GOTO EXIT
KILL DIC
+11 SET NEWIEN=+Y
+12 LOCK +^QA(745.2,NEWIEN):0
IF '$TEST
WRITE "Try again later."
GOTO SLCHEAD
+13 KILL DIE
SET DIE="^QA(745.2,"
SET DA=NEWIEN
SET DR="1////0;3////"_QASPECT_";4////L;2;5"
+14 DO ^DIE
KILL DIE
LOCK -^QA(745.2,NEWIEN)
+15 QUIT
EDIT ;Edit an existing code text.
+1 LOCK +^QA(745.2,QACIEN):0
IF '$TEST
WRITE "Try again later."
GOTO SLCHEAD
+2 KILL DIE
SET DIE="^QA(745.2,"
SET DA=QACIEN
SET DR="2;4;5"
+3 DO ^DIE
KILL DIE
LOCK -^QA(745.2,QACIEN)
+4 QUIT
EXIT ;
+1 KILL DIC,DIE,QACIEN,ALPHCODE,NEXNUM,NEWIEN,NUM,Y,X,FLAG
+2 KILL DA,DIRUT,DR,QASPECT
+3 QUIT
