source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACEDIT.m@ 789

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1QACEDIT ;HISC/RS,CEW,DAD - Edit routine for the Patient representative package ;3/21/95 10:18
2 ;;2.0;Patient Representative;**3,5,10,17**;07/25/1995
3 S (DIC,DIE)="^QA(745.1,",DIC(0)="AEMQZ",DIC("A")="Select CONTACT NUMBER: "
4 S DIC("S")="I ($P($G(^QA(745.1,+Y,7)),""^"",2)=""O""),(($D(^XUSEC(""QAC EDIT"",DUZ))#2)!(DUZ=$P(^QA(745.1,+Y,0),U,7)))"
5 D ^DIC I Y<0 K DIC,DIE Q
6 ;DISPLAY CONTACT DATA NOT EDITABLE
7EDT ;Entry point for editing open ROCs on same patient from option 'Enter
8 ;New Contact'
9 N QACPSRV,QACGWV
10 S RECNR=+Y L +^QA(745.1,RECNR):0 I '$T W !!,"Record being edited by another user." G END
11 N QACPN S QACPN=$P(^QA(745.1,RECNR,0),U,3)
12 K DA,DR,DIC,DIQ,TMP
13 S DA=+Y,DIC=745.1,DIQ="TMP",DR=".01;1;2;3;4;5;6;7" D EN^DIQ1
14 I '$G(QACFLG) W @IOF
15 W !!,?15,"Edit Patient Representative Contact",!
16 S N1="" F S N1=$O(TMP(745.1,N1)) Q:N1="" S N2="" F S N2=$O(TMP(745.1,N1,N2)) Q:N2="" S QACDATA=TMP(745.1,N1,N2) D
17 .Q:QACDATA=""
18 .S FLD=N2*100\1,TEXT=$P($T(@FLD),";;",2),TAB=$P(TEXT,"^"),LINE=$P(TEXT,"^",2),CODE=$P(TEXT,"^",3,99)
19 .W:TAB=0 !
20 .W ?TAB,LINE
21 .X CODE
22 .Q
23 I QACPN'="" S QACPSRV=$P($G(^DPT(QACPN,.32)),U,3),QACGWV=$P($G(^DPT(QACPN,.322)),U,10)
24 S DIE="^QA(745.1,",DA=RECNR,DR="31////"_$G(QACPSRV)_";32////"_$G(QACGWV) D ^DIE
25 I $G(QACPSRV)]"" W !,"Period of Service: ",?20,$P(^DIC(21,$G(QACPSRV),0),U)
26 W ?47,"Persian Gulf War?:",?66,$S($G(QACGWV)="Y":"YES",$G(QACGWV)="N":"NO",$G(QACGWV)="U":"UNKNOWN",1:"Not Entered")
27 ;I $P($G(^QA(745.1,RECNR,0)),U,16)]"" W !,"Division: ",?20,$P(^DIC(4,$P(^QA(745.1,RECNR,0),U,16),0),U)
28 I $P($G(^QA(745.1,RECNR,0)),U,16)]"" D
29 . S QAC1DIV=$P($G(^QA(745.1,RECNR,0)),U,16)
30 . S QACDVNAM="" D INST^QACUTL0(QAC1DIV,.QACDVNAM)
31 . W !,"Division: ",?20,QACDVNAM
32 S DFN=$P(^QA(745.1,RECNR,0),U,3) I DFN'="" D DIS^DGRPDB
33 K TMP,DIQ,N1,N2,QACDATA,FLD,TAB,TEXT,LINE,CODE
34 ;Enter edit rest of the data
35EDIT ;
36 N QACEE,QACLIST,QACNT S QACNT=0
37 I QACPN'="" W ! S QACPN=$P($G(^QA(745.1,DA,0)),"^",3),QACALERT=1
38 I $G(QACPN)]"" S DR=16.5 D ^DIE
39 S DR="[QAC CONTACT ENTER/EDIT]"
40 D ^DIE K DIE
41END L -^QA(745.1,RECNR)
42 Q:$G(QACFLG)
43 K DIC,DR,DIE,DA,D0,DO,QACPN,X,Y,RECNR,BY,DFN,DHD,DLAYGO,FLDS,FR,IOP,L
44 K QACD1,QACDFLT,QACOUT,TO,QACALERT,QACDVNAM
45 W !! G ^QACEDIT
46TEXT ;This is for the display of data, tab, description, data info.
471 ;;0^Contact Number:^W ?20,QACDATA
48100 ;;47^Date of Contact:^W ?66,QACDATA
49200 ;;0^Patient Name:^W ?20,QACDATA
50300 ;;47^Patient SSN (c):^W ?66,QACDATA
51400 ;;0^Patient DOB (c):^S Y=QACDATA D DD^%DT S QACDATA=Y W ?20,QACDATA
52500 ;;47^Patient sex (c):^W ?66,QACDATA
53600 ;;0^Eligibility Status:^W ?20,QACDATA
54700 ;;47^Patient Category:^W ?66,QACDATA
553100 ;;0^Period of Service:^W ?20,$P(^DIC(21,$G(QACDATA),0),U)
56 Q
57IDSPLAY ;If the site wants to display the Issue Codes and Services
58 ;IDSPLAY is used. See Site Parameters.
59 W !!,?10,"Previously Entered Issue Codes:",!!
60 I $O(^QA(745.1,DA,3,0)) S QACNUM=DA D CODES^QACNEW
61 I '$O(^QA(745.1,DA,3,0)) W ?3,"None!",!
62 ;. S DIC="^QA(745.1,",L=0,DHD="@@"
63 ;. S FLDS="21,.01;C3;L60,"" (*"",:745.2:7,"")""1,.01;C10,",BY="@NUMBER",(FR,TO)=DA
64 ;. S IOP="HOME" D EN1^DIP
65 ;E W ?3,"None!",!
66 Q
Note: See TracBrowser for help on using the repository browser.