source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSCNV3.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: 2.9 KB
Line 
1QAOSCNV3 ;HISC/DAD-ASSOCIATED ADMISSION, COMMENTS FIELDS & E XREF ;7/26/93 12:18
2 ;;3.0;Occurrence Screen;;09/14/1993
3 G:$O(^QA(741,0))'>0 EXIT
4 W !!,"Load ASSOCIATED ADMISSION field,"
5 W !,"convert COMMENTS to word processing"
6 W !,"and, index the 'E' cross reference"
7 W !,"-----------------------------------",!
8 W !!?5,"The associated admission dates will now be calculated for all"
9 W !?5,"Occurrence Screen records. The data is saved in the ASSOCIATED"
10 W !?5,"ADMISSION field (741,.02). Depending on the number of"
11 W !?5,"occurrences, this could take quite a while."
12 W !!?5,"Also, the data in the COMMENTS fields in the REVIEWER and"
13 W !?5,"COMMITTEE multiples (741.01,7 & 741.017,3) is copied to the"
14 W !?5,"new word processing COMMENTS fields (741.01,10 & 741.017,10)."
15 W !?5,"The old free text comments are deleted as they are converted."
16 W !?5,"The 'E' cross reference on the OCCURRENCE IDENTIFIER field"
17 W !?5,"(#741,2) will also be created."
18 W !!,"Working" S QAORECRD=$G(QAORECRD) K ^QA(741,"E")
19 F QAOSD0=0:0 S QAOSD0=$O(^QA(741,QAOSD0)) Q:QAOSD0'>0 D
20 . W:QAORECRD#10'>0 "." S QAORECRD=QAORECRD+1
21 . D AADM,REVR,CMTE
22 . Q
23EXIT ;
24 K %,BEG,DA,DFN,DIE,DR,END,QAOSD0,QAOSD1,QAOSD2,QAOSDATE,QAOSDFN
25 K QAOSTEXT,QAOSWORD,QAOSZERO,X,Y D KVAR^VADPT
26 Q
27AADM ; ASSOCIATED ADMISSION & 'E' XREF
28 S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO=""
29 S X=$P(QAOSZERO,"^",4) S:X]"" ^QA(741,"E",$E(X,1,30),QAOSD0)=""
30 Q:$P(QAOSZERO,"^",2)
31 S QAOSDFN=+QAOSZERO,QAOSDATE=+$P(QAOSZERO,"^",3)
32 Q:QAOSDATE'>0 Q:$D(^DPT(QAOSDFN,0))[0
33 K VAIP S DFN=QAOSDFN,VAIP("D")=QAOSDATE\1,VAIP("M")=0 D IN5^VADPT
34 I $D(^DGPM(+VAIP(1),0))#2,QAOSDATE\1'<(VAIP(3)\1) D
35 . S DIE="^QA(741,",DR=".02///`"_+VAIP(1),DA=QAOSD0 D ^DIE
36 . Q
37 Q
38REVR ; REVIEWER MULTIPLE
39 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR",QAOSD1)) Q:QAOSD1'>0 D
40 . S QAOSTEXT=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",7)
41 . Q:QAOSTEXT="" Q:$D(^QA(741,QAOSD0,"REVR",QAOSD1,3,0))#2
42 . F QAOSD2=1:1 D Q:QAOSTEXT=""
43 .. S QAOSWORD=$L($E(QAOSTEXT,1,61)," "),X=$P(QAOSTEXT," ",1,QAOSWORD)
44 .. S ^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSD2,0)=$$SPC(X)
45 .. S QAOSTEXT=$P(QAOSTEXT," ",QAOSWORD+1,999)
46 .. Q
47 . S ^QA(741,QAOSD0,"REVR",QAOSD1,3,0)="^741.02^"_QAOSD2_"^"_QAOSD2
48 . S $P(^QA(741,QAOSD0,"REVR",QAOSD1,0),"^",7)=""
49 . Q
50 Q
51CMTE ; COMMITTEE MULTIPLE
52 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D
53 . S QAOSTEXT=$P($G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",4)
54 . Q:QAOSTEXT="" Q:$D(^QA(741,QAOSD0,"CMTE",QAOSD1,1,0))#2
55 . F QAOSD2=1:1 D Q:QAOSTEXT=""
56 .. S QAOSWORD=$L($E(QAOSTEXT,1,61)," "),X=$P(QAOSTEXT," ",1,QAOSWORD)
57 .. S ^QA(741,QAOSD0,"CMTE",QAOSD1,1,QAOSD2,0)=$$SPC(X)
58 .. S QAOSTEXT=$P(QAOSTEXT," ",QAOSWORD+1,999)
59 .. Q
60 . S ^QA(741,QAOSD0,"CMTE",QAOSD1,1,0)="^741.027^"_QAOSD2_"^"_QAOSD2
61 . S $P(^QA(741,QAOSD0,"CMTE",QAOSD1,0),"^",4)=""
62 . Q
63 Q
64SPC(X) ; REMOVE LEADING AND TRAILING SPACES
65 N BEG,END
66 F BEG=1:1 Q:$E(X,BEG)'=" "
67 F END=$L(X):-1 Q:$E(X,END)'=" "
68 Q $E(X,BEG,END)
Note: See TracBrowser for help on using the repository browser.