source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACNEW.m@ 1123

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1QACNEW ;HISC/RS,CEW,DAD-Enter a new Patient representative record ; 11/24/00 1:40pm
2 ;;2.0;Patient Representative;**3,5,8,10,11,13,16,17**;07/25/1995
3 S DIR("A")="Enter Date of Contact: ",DIR(0)="DOA^2010101:"_DT_":PEX"
4 S DIR("?")="^D HELP^%DTC",DIR("??")="^D HELP^QACNEW"
5 D ^DIR K DIR
6 G QUIT:$D(DIROUT)!($D(DIRUT))
7 S QACDOC=Y
8 K DA S DIR("A")="Enter Patient Name",DIR(0)="745.1,2"
9 D ^DIR K DIR
10 G QUIT:$D(DIROUT)!($D(DTOUT))!($D(DUOUT))
11 ;
12 N QACNAME,QACPAT,QACPSRV,QACGWV,RECNR
13 ;
14 S QACPN=$P(Y,"^",1)
15 S QACINCR=0
16 G:QACPN="" QACRECN
17SHOW S (QACELI,QACCAT,QACSSN,QACDOB)="",QACY=+Y
18 I QACPN'="" S QACDATA=$G(^DPT(QACPN,0)),QACNAME=$P(QACDATA,"^") D
19 .S QACSSN=$P(QACDATA,"^",9),QACDOB=$P(QACDATA,"^",3),QACSEX=$P(QACDATA,"^",2) S DFN=QACPN D ELIG^VADPT S QACELI=$P($G(VAEL(1)),"^",2),QACCAT=$P($G(VAEL(9)),"^",2)
20 I QACPN'="" S QACPSRV=$P($G(^DPT(QACPN,.32)),U,3)
21 I QACPN'="" S QACGWV=$P($G(^DPT(QACPN,.322)),U,10)
22 W @IOF,!!,?15,"Enter New Patient Representative Contact",!
23 I QACPN'="" S QACPAT=^DPT(QACPN,0)
24 W !,"Patient Name:",?20,$P($G(QACPAT),U)
25 W ?47,"Patient SSN:",?66,$P($G(QACPAT),U,9)
26 S Y=$P($G(QACPAT),U,3) D DD^%DT W !,"Patient DOB: ",?20,$G(Y)
27 W ?47,"Patient Sex:",?66,$P($G(QACPAT),U,2)
28 W !,"Eligibility Status:",?20,$G(QACELI)
29 W ?47,"Patient Category:",?66,$G(QACCAT)
30 I $G(QACPSRV)]"" W !,"Period of Service: ",?20,$P(^DIC(21,$G(QACPSRV),0),U)
31 W ?47,"Persian Gulf War?: ",?66,$S($G(QACGWV)="Y":"YES",$G(QACGWV)="N":"NO",$G(QACGWV)="U":"UNKNOWN",1:"Not Entered")
32 N CNT1,CNT2,J,K,L,M,N,QACCODE,QACCSS,QACFLG,QACNUM,QACOPEN,QACROC,QACSS
33 I QACPN'="" S J="",CNT1=0 F S J=$O(^QA(745.1,"E",QACPN,J)) Q:'J D
34 . S CNT1=CNT1+1
35 . S QACROC(CNT1)=J
36 I $G(CNT1)>0 D
37 . W !!,"Last ROC for ",QACNAME,": ",$P(^QA(745.1,QACROC(CNT1),0),U)
38 . S Y=$P(^QA(745.1,QACROC(CNT1),0),U,2) D DD^%DT
39 . W " Date: ",Y
40 . I $G(^QA(745.1,QACROC(CNT1),3,0))]"" S QACNUM=QACROC(CNT1) D CODES
41 I QACPN'="" S DFN=QACPN D DIS^DGRPDB
42 I $G(CNT1)>0 D
43 . S K=0,CNT2=0 F S K=$O(QACROC(K)) Q:'K Q:QACROC(K)'>0 D
44 . . I '$D(^XUSEC("QAC EDIT",DUZ))#2,(DUZ'=$P(^QA(745.1,QACROC(K),0),U,7)) Q
45 . . I $P($G(^QA(745.1,QACROC(K),7)),U,2)="O" S CNT2=CNT2+1,QACOPEN(CNT2)=QACROC(K)
46 I $G(CNT2)'>0,(QACPN'="") W !!,"There are no open Contacts on patient ",$P(^DPT(QACPN,0),U),"."
47 N %
48 I $G(CNT2)>0 W !!,"Would you like to edit open ROC(s) at this time" S %=0 D YN^DICN W:%'=1 !! I %=1 D
49 . I CNT2>1,(QACPN'="") D
50EDOPEN . . ; If user chooses, can edit open ROCs on this patient.
51 . . W !!?10,"Edit an open Report of Contact on ",$P(^DPT(QACPN,0),U)
52 . . W !,"Choose from: "
53 . . S L=0 F S L=$O(QACOPEN(L)) Q:'L D
54 . . . I $D(^XUSEC("QAC EDIT",DUZ))#2!(DUZ=$P(^QA(745.1,QACOPEN(L),0),U,7)) W !,L," ",$P(^QA(745.1,QACOPEN(L),0),U) S Y=$P(^QA(745.1,QACOPEN(L),0),U,2) D DD^%DT W ?40,"Date: ",Y S QACNUM=QACOPEN(L) D CODES
55 . . S DIR(0)="NO",DIR("S")="I X>0,(X<QACLAST+1)"
56 . . S DIR("?")="Enter the list number of your selection."
57 . . D ^DIR Q:$D(DIRUT)
58 . . S (RECNR,Y)=QACOPEN(X),QACFLG=1,DIE=745.1
59 . . D EDT^QACEDIT G EDOPEN
60 . . W !!!!,"****Returning to 'Enter New Contact' session.****",!!
61 . I CNT2=1 D
62 . . S (Y,RECNR,QACNUM)=QACOPEN(CNT2),QACFLG=1
63 . . W !!!,$P(^QA(745.1,QACNUM,0),U) S Y=$P(^QA(745.1,QACNUM,0),U,2) D DD^%DT W ?40,"Date: ",Y
64 . . D CODES
65 . . S Y=QACNUM D EDT^QACEDIT
66 . . W !!!!,"****Returning to 'Enter New Contact' session.****",!!
67 S QACINCR=0
68QACRECN ; Build next contact number
69 N QACLEN,QACLEN1,QACNO,QACNT S QACNT=0
70 S QACYR=$E(DT,2,3),(QACRCFLG,QAC)=+$P($G(^QA(745.1,0)),U,3)
71 I $G(QACRCFLG) D
72 . S QAC=$O(^QA(745.1," "),-1) Q:QAC'>0 S QACRCFLG=QAC
73 . S QACRCD(1)=$P($G(^QA(745.1,QACRCFLG,0)),U)
74 . S QACRCD(2)=$P($$SITE^VASITE(DT),U,3) ;QAC*2*13 - use api for station # QAC*2*16 - access 3rd piece
75 . S QACLEN1=$L(QACRCD(2))
76 . S QACRCD(3)=$E(QACRCD(1),QACLEN1+1,999)
77 . I QACYR'=$E(QACRCD(3),2,3) S QACRCD="."_QACYR_"000"_1+QACINCR Q
78 . ; splitting off contact number from year to allow for >9999 records
79 . ; per year. patch QAC*2*8 - ERC
80 . S QACRCD(4)=$E(QACRCD(3),4,999)
81 . S QACRCD(4)=QACRCD(4)+1+QACINCR
82 . S QACLEN=$L(QACRCD(4))
83 . S QACRCD="."_QACYR_QACRCD(4)
84 . I QACLEN<4 S QACRCD="."_QACYR_$E("000",1,(4-QACLEN))_QACRCD(4)
85 E S QACRCD="."_QACYR_"000"_1+QACINCR
86 S QACCASE=QACRCD(2)_QACRCD
87 I $O(^QA(745.1,"B",QACCASE,0))>0 S QACINCR=QACINCR+1 G QACRECN
88 S QACLC="L +X"_$P(QACCASE,".",2)_":0"
89 X QACLC I '$T S QACINCR=QACINCR+1 G QACRECN
90 K DIC,DD,DO,DINUM,DLAYGO S X=QACCASE
91 S DIC("DR")="",DIC(0)="EMQLZ",(DIC,DLAYGO)=745.1 D ^DIC K DIC
92 S QACLC="L -X"_$P(QACCASE,".",2) X QACLC G END:Y<0
93 S QACDA=+Y
94 Q:$G(DUOUT)
95 D DIVLIST
96 ;S DIE="^QA(745.1,",DR=37 D ^DIE
97 ;S QACDA=QAC+1
98 S QACALERT=1
99 S DIE="^QA(745.1,",DA=QACDA,DR="1////"_QACDOC_";2////"_$G(QACPN)_";9////"_DUZ_";27///^S X=""O"";6////"_$G(QACELI)_";7///"_$G(QACCAT)_";31////"_$G(QACPSRV)_";32////"_$G(QACGWV) D ^DIE
100 K DIC,DIQ,DR
101 ;I QACPN'="" S DFN=QACPN D DIS^DGRPDB
102 K TMP,DFN,CODE,DIQ,DIR,DR,LINE,N1,N2,QAC,QACCASE,QACCAT,QACDATA,QACDOB,QACDOC,QACELI,QACFL1,QACRCD,QACRCD(1),QACRCD(2),QACRCFLG,QACSEX,QACSITE,QACSSN,QACYR,TAB,TEXT,VAEL,QACY
103EDIT ;FILL IN REST OF DATA FIELDS
104 W ! S DIE="^QA(745.1,"
105 S DA=QACDA
106 I $G(QACPN)]"" S DR=16.5 D ^DIE
107 S DR="[QAC CONTACT ENTER/EDIT]"
108 D ^DIE
109END K D,D0,DA,DD,DI,DIC,DIE,DIR,DLAYGO,DTOUT,DO,DR,DUOUT,FLD,J,TEMPY,X,Y
110 K QACALERT,QACCASE,QACD1,QACDA,QACDFLT,QACFL1,QACINCR,QACLAST,QACLC,QACN,QACOPEN,QACOUT,QACPN,QACY,QACDVNAM
111 W !! G ^QACNEW
112HELP ;
113 W !!,"This is the date the Patient Representative was initially contacted."
114 W !,"Enter a date no later than TODAY."
115 Q
116TEXT ;
1171 ;;0^Contact Number:^W ?20,QACDATA
118100 ;;47^Date of Contact:^W ?66,QACDATA
119200 ;;0^Patient Name:^W ?20,QACDATA
120300 ;;47^Patient SSN (c):^W ?66,QACDATA
121400 ;;0^Patient DOB (c):^S Y=QACDATA D DD^%DT S QACDATA=Y W ?20,QACDATA
122500 ;;47^Patient sex (c):^W ?66,QACDATA
123600 ;;0^Eligibility Status:^W ?20,QACDATA
124700 ;;47^Patient Category:^W ?66,QACDATA
125 ;
126QUIT K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
127 K QACALERT,QACDOC,QACFL1,QACPN,QACRCD,QACY
128 Q
129CODES ; Display Issue Codes and Customer Service Standards with ROC
130 W !?3,"Issue Code(s):"
131 S M=0
132 F S M=$O(^QA(745.1,QACNUM,3,M)) Q:'M S QACCODE=^QA(745.1,QACNUM,3,M,0) D
133 . W !,$P(^QA(745.2,QACCODE,0),U)_"-"_$P(^QA(745.2,QACCODE,0),U,3)
134 . S QACCSS=$P(^QA(745.2,QACCODE,0),U,7)
135 . I $G(QACCSS)]"" S N="" S QACSS=$O(^QA(745.6,"B",QACCSS,N)) W "(*",$P(^QA(745.6,QACSS,0),U,2),")"
136 Q
137DIVLIST ;
138 ;W !!,"DIVISION: "
139 N QAC,QACC
140 S (QAC,QACC)=0
141 F S QACC=$O(^DG(40.8,"AD",QACC)) Q:QACC'>0 D
142 . S QAC=QAC+1
143 . S QAC(QAC)=QAC
144 . S QACC(QAC)=QACC
145 . I $D(^DIC(4,QACC,0)) W !," "_QAC(QAC)_" "_$P(^DIC(4,QACC,0),U)
146 S DIR(0)="NA"
147 S DIR("A")="Enter your Division: "
148 S DIR("?")="Choose the number of your division."
149 D ^DIR K DIR
150 Q:$G(DIRUT)
151 I $G(QAC(+Y))]"" S QAC=$P($G(^DIC(4,QACC(+Y),0)),U)
152 S DR="37///^S X=QAC",DIE="^QA(745.1,",DA=QACDA D ^DIE
153 Q
Note: See TracBrowser for help on using the repository browser.