| [613] | 1 | QACPOST ;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
|
|---|
| 5 | DEMOG ; 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)
|
|---|
| 13 | ISS ; 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
|
|---|
| 17 | DIV ; 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)=""
|
|---|
| 33 | DATE ; 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)=""
|
|---|
| 42 | DISC ; 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
|
|---|
| 56 | DISC2 ;
|
|---|
| 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
|
|---|
