source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACCODE.m@ 914

Last change on this file since 914 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.2 KB
Line 
1QACCODE ;HISC/CEW - Enter/Edit a Local Contact Issue Code ;1/30/95 09:02
2 ;;2.0;Patient Representative;**3**;07/25/1995
3 ;*********Variable List*********************************
4 ;ALPHCODE =The major heading (ALPHA) code
5 ;QASPECT =The IEN of the Quality Aspect
6 ;NEXNUM =Next free number
7 ;NUM =The last code number
8 ;NEWIEN =The IEN of the new code
9 ;QACIEN =The IEN of the Issue
10 ;
11 ;
12 ;
13 ;
14 ; This option no longer in use, as Issue Codes can no longer be
15 ; entered or edited
16 W !!?5,"Issue Codes can no longer be entered or edited."
17 W !?5,"Only National Issue Codes are valid."
18 W !?5,"The Issue Code list will be periodically evaluated and updated."
19 Q
20SLCHEAD ;
21 ;Selects code to edit code text and status or a major heading
22 ;under which a new code will reside.
23 W ! K DIC S DIC="^QA(745.2,",DIC(0)="AEQZ"
24 S DIC("A")="Select ISSUE CODE: "
25 S DIC("S")="I ($P(^(0),U,5)'=""N""!($P(^(0),U,2)=1)),($P(^(0),U,1)?2U.N)"
26 D ^DIC K DIC G:Y'>0 EXIT
27 S ALPHCODE=Y(0,0),NUM=99,QASPECT=$P(Y(0),"^",4),QACIEN=+Y
28 ;Find out if selection is a major code (ALPHA only) heading
29 ;to ENTER a new code text or else a numbered code for EDITing.
30 I $P(Y(0),U,2)="1" S FLAG=0 D ENTER G SLCHEAD
31 E D EDIT G SLCHEAD
32ENTER ;Enter a new code text. Code number is built in background.
33 F S NUM=$O(^QA(745.2,"AH",ALPHCODE,NUM)) D Q:FLAG=1
34 .I NUM'>200 S NEXNUM=ALPHCODE_"201" S FLAG=1 Q
35 .S NEXNUM=ALPHCODE_(NUM+1)
36 .I '$D(^QA(745.2,"B",NEXNUM)) S FLAG=1
37 .Q
38 I $E(NEXNUM,2,4)>999 W !,"Only 999 issue codes allowed per heading! Select a different heading." G SLCHEAD
39 K DIR S DIR("A")="Are you adding '"_NEXNUM_"' as a new Contact Issue Code",DIR("0")="Y",DIR("B")="YES"
40 D ^DIR K DIR Q:($D(DIRUT))!(Y=0)
41 S DIC(0)="EMQLZ",DIC="^QA(745.2,",X=NEXNUM
42 D FILE^DICN G EXIT:Y<1 K DIC
43 S NEWIEN=+Y
44 L +^QA(745.2,NEWIEN):0 I '$T W "Try again later." G SLCHEAD
45 K DIE S DIE="^QA(745.2,",DA=NEWIEN,DR="1////0;3////"_QASPECT_";4////L;2;5"
46 D ^DIE K DIE L -^QA(745.2,NEWIEN)
47 Q
48EDIT ;Edit an existing code text.
49 L +^QA(745.2,QACIEN):0 I '$T W "Try again later." G SLCHEAD
50 K DIE S DIE="^QA(745.2,",DA=QACIEN,DR="2;4;5"
51 D ^DIE K DIE L -^QA(745.2,QACIEN)
52 Q
53EXIT ;
54 K DIC,DIE,QACIEN,ALPHCODE,NEXNUM,NEWIEN,NUM,Y,X,FLAG
55 K DA,DIRUT,DR,QASPECT
56 Q
Note: See TracBrowser for help on using the repository browser.