| 1 | QAOSCNV3 ;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
|
|---|
| 23 | EXIT ;
|
|---|
| 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
|
|---|
| 27 | AADM ; 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
|
|---|
| 38 | REVR ; 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
|
|---|
| 51 | CMTE ; 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
|
|---|
| 64 | SPC(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)
|
|---|
