source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACPOST.m@ 1211

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1QACPOST ;WCIOFO/ERC-Post-install for patch-Update 745.1,745.2 ;7/24/97
2 ;;2.0;Patient Representative;**3**;07/25/1995
3 ; Set Period of Service and Persian Gulf Service? fields in 745.1.
4 ; Change 'Local' Issue Codes to 'Inactive' in file 745.2
5DEMOG ; Add new demographic fields
6 N QACCNUM,QACPTNUM
7 S QACCNUM=0
8 F S QACCNUM=$O(^QA(745.1,QACCNUM)) Q:QACCNUM'>0 D
9 . S QACPTNUM=$P(^QA(745.1,QACCNUM,0),U,3)
10 . Q:$G(QACPTNUM)']""
11 . S $P(^QA(745.1,QACCNUM,0),U,14)=$P($G(^DPT(QACPTNUM,.32)),U,3)
12 . S $P(^QA(745.1,QACCNUM,0),U,15)=$P($G(^DPT(QACPTNUM,.322)),U,10)
13ISS ; Change any 'Local' Issue Codes in file 745.2 to 'Inactivated'.
14 N QACCODE
15 S QACCODE=0
16 F S QACCODE=$O(^QA(745.2,QACCODE)) Q:QACCODE'>0 I $P(^QA(745.2,QACCODE,0),U,5)="L" S $P(^QA(745.2,QACCODE,0),U,5)=1
17DIV ; Add divisions to file 740 if site is multi-divisional for Pat. Rep.
18 N EE,QACCNT,QACDIVN,QACTYPE
19 I $G(^DIC(4,$P(^QA(740,1,0),U),"DIV"))["Y" D
20 .S EE=0
21 .F S EE=$O(^DG(40.8,EE)) Q:EE'>0 D
22 . . S QACDIVN=$P($G(^DG(40.8,EE,0)),U,7)
23 . . Q:$G(QACDIVN)']"" S QACTYPE=$G(^DIC(4,QACDIVN,3))
24 . . I EE=1 S QACTYPE=1
25 . . I $G(QACTYPE)]"" I $S(QACTYPE=1:1,QACTYPE=8:1,QACTYPE=16:1,1:0) D
26 . . . S $P(^QA(740,1,"OS"),U,9)=1
27 . . . I '$D(^QA(740,1,"OS2",0)) S ^QA(740,1,"OS2",0)="^740.02IPA^0^0"
28 . . . S QACCNT=$P(^QA(740,1,"OS2",0),U,3)+1
29 . . . S $P(^QA(740,1,"OS2",0),U,3,4)=QACCNT
30 . . . S $P(^QA(740,1,"OS2",EE,0),U)=EE
31 . . . S ^QA(740,1,"OS2","B",EE,EE)=""
32 I $G(^DIC(4,$P(^QA(740,1,0),U),"DIV"))']"Y" S $P(^QA(740,1,"OS"),U,9)=""
33DATE ; Correct data already entered in test sites for date resolved.
34 ; Had originally planned to replace date closed with date closed,
35 ; but now will just change name. This subroutine will move any
36 ; data in date resolved to date closed and set field date resolved
37 ; to null.
38 S EE=0
39 F S EE=$O(^QA(745.1,EE)) Q:EE'>0 D
40 . I $D(^QA(745.1,EE,7)) I $P(^QA(745.1,EE,7),U,3)]"" S $P(^QA(745.1,EE,7),U)=$P(^QA(745.1,EE,7),U,3)
41 . S $P(^QA(745.1,EE,7),U,3)=""
42DISC ; Correct data at test sites that had been entered in discipline
43 ; sub-file. Design change put this information in service/discipline
44 ; sub-file. This subroutine will move the data to the new location
45 ; and delete the discipline sub-file.
46 N QACDISC,QACSV
47 N EE,FF,GG,HH S EE=2970704
48 F S EE=$O(^QA(745.1,"D",EE)) Q:EE'>0 D
49 . S FF=0 F S FF=$O(^QA(745.1,"D",EE,FF)) Q:FF'>0 D
50 . . S GG=0 F S GG=$O(^QA(745.1,FF,3,GG)) Q:GG="" D
51 . . . S HH=0 F S HH=$O(^QA(745.1,FF,3,GG,2,HH)) Q:HH'>0 D DISC2
52 . . . Q
53 . . Q
54 . Q
55 Q
56DISC2 ;
57 S QACDISC=$P(^QA(745.1,FF,3,GG,2,HH,0),U)
58 S QACSV=$P(^QA(745.55,$G(QACDISC),0),U)
59 S DA(2)=FF,DA(1)=GG,X=QACSV
60 S DIC="^QA(745.1,DA(2),3,DA(1),3,"
61 S DIC(0)="L"
62 S DIC("P")=$P(^DD(745.121,3,0),U,2)
63 D ^DIC
64 S $P(^QA(745.1,FF,3,GG,3,HH,0),U,2)=QACDISC
65 S DIK="^QA(745.1,DA(2),3,DA(1),2,",DA=HH
66 D ^DIK K DIK
67 Q
Note: See TracBrowser for help on using the repository browser.