QAOSCNV3 ;HISC/DAD-ASSOCIATED ADMISSION, COMMENTS FIELDS & E XREF ;7/26/93 12:18
;;3.0;Occurrence Screen;;09/14/1993
G:$O(^QA(741,0))'>0 EXIT
W !!,"Load ASSOCIATED ADMISSION field,"
W !,"convert COMMENTS to word processing"
W !,"and, index the 'E' cross reference"
W !,"-----------------------------------",!
W !!?5,"The associated admission dates will now be calculated for all"
W !?5,"Occurrence Screen records. The data is saved in the ASSOCIATED"
W !?5,"ADMISSION field (741,.02). Depending on the number of"
W !?5,"occurrences, this could take quite a while."
W !!?5,"Also, the data in the COMMENTS fields in the REVIEWER and"
W !?5,"COMMITTEE multiples (741.01,7 & 741.017,3) is copied to the"
W !?5,"new word processing COMMENTS fields (741.01,10 & 741.017,10)."
W !?5,"The old free text comments are deleted as they are converted."
W !?5,"The 'E' cross reference on the OCCURRENCE IDENTIFIER field"
W !?5,"(#741,2) will also be created."
W !!,"Working" S QAORECRD=$G(QAORECRD) K ^QA(741,"E")
F QAOSD0=0:0 S QAOSD0=$O(^QA(741,QAOSD0)) Q:QAOSD0'>0 D
. W:QAORECRD#10'>0 "." S QAORECRD=QAORECRD+1
. D AADM,REVR,CMTE
. Q
EXIT ;
K %,BEG,DA,DFN,DIE,DR,END,QAOSD0,QAOSD1,QAOSD2,QAOSDATE,QAOSDFN
K QAOSTEXT,QAOSWORD,QAOSZERO,X,Y D KVAR^VADPT
Q
AADM ; ASSOCIATED ADMISSION & 'E' XREF
S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO=""
S X=$P(QAOSZERO,"^",4) S:X]"" ^QA(741,"E",$E(X,1,30),QAOSD0)=""
Q:$P(QAOSZERO,"^",2)
S QAOSDFN=+QAOSZERO,QAOSDATE=+$P(QAOSZERO,"^",3)
Q:QAOSDATE'>0 Q:$D(^DPT(QAOSDFN,0))[0
K VAIP S DFN=QAOSDFN,VAIP("D")=QAOSDATE\1,VAIP("M")=0 D IN5^VADPT
I $D(^DGPM(+VAIP(1),0))#2,QAOSDATE\1'<(VAIP(3)\1) D
. S DIE="^QA(741,",DR=".02///`"_+VAIP(1),DA=QAOSD0 D ^DIE
. Q
Q
REVR ; REVIEWER MULTIPLE
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR",QAOSD1)) Q:QAOSD1'>0 D
. S QAOSTEXT=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",7)
. Q:QAOSTEXT="" Q:$D(^QA(741,QAOSD0,"REVR",QAOSD1,3,0))#2
. F QAOSD2=1:1 D Q:QAOSTEXT=""
.. S QAOSWORD=$L($E(QAOSTEXT,1,61)," "),X=$P(QAOSTEXT," ",1,QAOSWORD)
.. S ^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSD2,0)=$$SPC(X)
.. S QAOSTEXT=$P(QAOSTEXT," ",QAOSWORD+1,999)
.. Q
. S ^QA(741,QAOSD0,"REVR",QAOSD1,3,0)="^741.02^"_QAOSD2_"^"_QAOSD2
. S $P(^QA(741,QAOSD0,"REVR",QAOSD1,0),"^",7)=""
. Q
Q
CMTE ; COMMITTEE MULTIPLE
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D
. S QAOSTEXT=$P($G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",4)
. Q:QAOSTEXT="" Q:$D(^QA(741,QAOSD0,"CMTE",QAOSD1,1,0))#2
. F QAOSD2=1:1 D Q:QAOSTEXT=""
.. S QAOSWORD=$L($E(QAOSTEXT,1,61)," "),X=$P(QAOSTEXT," ",1,QAOSWORD)
.. S ^QA(741,QAOSD0,"CMTE",QAOSD1,1,QAOSD2,0)=$$SPC(X)
.. S QAOSTEXT=$P(QAOSTEXT," ",QAOSWORD+1,999)
.. Q
. S ^QA(741,QAOSD0,"CMTE",QAOSD1,1,0)="^741.027^"_QAOSD2_"^"_QAOSD2
. S $P(^QA(741,QAOSD0,"CMTE",QAOSD1,0),"^",4)=""
. Q
Q
SPC(X) ; REMOVE LEADING AND TRAILING SPACES
N BEG,END
F BEG=1:1 Q:$E(X,BEG)'=" "
F END=$L(X):-1 Q:$E(X,END)'=" "
Q $E(X,BEG,END)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSCNV3 3037 printed Apr 09, 2024@21:23:33 Page 2
QAOSCNV3 ;HISC/DAD-ASSOCIATED ADMISSION, COMMENTS FIELDS & E XREF ;7/26/93 12:18
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 if $ORDER(^QA(741,0))'>0
GOTO EXIT
+3 WRITE !!,"Load ASSOCIATED ADMISSION field,"
+4 WRITE !,"convert COMMENTS to word processing"
+5 WRITE !,"and, index the 'E' cross reference"
+6 WRITE !,"-----------------------------------",!
+7 WRITE !!?5,"The associated admission dates will now be calculated for all"
+8 WRITE !?5,"Occurrence Screen records. The data is saved in the ASSOCIATED"
+9 WRITE !?5,"ADMISSION field (741,.02). Depending on the number of"
+10 WRITE !?5,"occurrences, this could take quite a while."
+11 WRITE !!?5,"Also, the data in the COMMENTS fields in the REVIEWER and"
+12 WRITE !?5,"COMMITTEE multiples (741.01,7 & 741.017,3) is copied to the"
+13 WRITE !?5,"new word processing COMMENTS fields (741.01,10 & 741.017,10)."
+14 WRITE !?5,"The old free text comments are deleted as they are converted."
+15 WRITE !?5,"The 'E' cross reference on the OCCURRENCE IDENTIFIER field"
+16 WRITE !?5,"(#741,2) will also be created."
+17 WRITE !!,"Working"
SET QAORECRD=$GET(QAORECRD)
KILL ^QA(741,"E")
+18 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,QAOSD0))
if QAOSD0'>0
QUIT
Begin DoDot:1
+19 if QAORECRD#10'>0
WRITE "."
SET QAORECRD=QAORECRD+1
+20 DO AADM
DO REVR
DO CMTE
+21 QUIT
End DoDot:1
EXIT ;
+1 KILL %,BEG,DA,DFN,DIE,DR,END,QAOSD0,QAOSD1,QAOSD2,QAOSDATE,QAOSDFN
+2 KILL QAOSTEXT,QAOSWORD,QAOSZERO,X,Y
DO KVAR^VADPT
+3 QUIT
AADM ; ASSOCIATED ADMISSION & 'E' XREF
+1 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
if QAOSZERO=""
QUIT
+2 SET X=$PIECE(QAOSZERO,"^",4)
if X]""
SET ^QA(741,"E",$EXTRACT(X,1,30),QAOSD0)=""
+3 if $PIECE(QAOSZERO,"^",2)
QUIT
+4 SET QAOSDFN=+QAOSZERO
SET QAOSDATE=+$PIECE(QAOSZERO,"^",3)
+5 if QAOSDATE'>0
QUIT
if $DATA(^DPT(QAOSDFN,0))[0
QUIT
+6 KILL VAIP
SET DFN=QAOSDFN
SET VAIP("D")=QAOSDATE\1
SET VAIP("M")=0
DO IN5^VADPT
+7 IF $DATA(^DGPM(+VAIP(1),0))#2
IF QAOSDATE\1'<(VAIP(3)\1)
Begin DoDot:1
+8 SET DIE="^QA(741,"
SET DR=".02///`"_+VAIP(1)
SET DA=QAOSD0
DO ^DIE
+9 QUIT
End DoDot:1
+10 QUIT
REVR ; REVIEWER MULTIPLE
+1 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:1
+2 SET QAOSTEXT=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",7)
+3 if QAOSTEXT=""
QUIT
if $DATA(^QA(741,QAOSD0,"REVR",QAOSD1,3,0))#2
QUIT
+4 FOR QAOSD2=1:1
Begin DoDot:2
+5 SET QAOSWORD=$LENGTH($EXTRACT(QAOSTEXT,1,61)," ")
SET X=$PIECE(QAOSTEXT," ",1,QAOSWORD)
+6 SET ^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSD2,0)=$$SPC(X)
+7 SET QAOSTEXT=$PIECE(QAOSTEXT," ",QAOSWORD+1,999)
+8 QUIT
End DoDot:2
if QAOSTEXT=""
QUIT
+9 SET ^QA(741,QAOSD0,"REVR",QAOSD1,3,0)="^741.02^"_QAOSD2_"^"_QAOSD2
+10 SET $PIECE(^QA(741,QAOSD0,"REVR",QAOSD1,0),"^",7)=""
+11 QUIT
End DoDot:1
+12 QUIT
CMTE ; COMMITTEE MULTIPLE
+1 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"CMTE",QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:1
+2 SET QAOSTEXT=$PIECE($GET(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",4)
+3 if QAOSTEXT=""
QUIT
if $DATA(^QA(741,QAOSD0,"CMTE",QAOSD1,1,0))#2
QUIT
+4 FOR QAOSD2=1:1
Begin DoDot:2
+5 SET QAOSWORD=$LENGTH($EXTRACT(QAOSTEXT,1,61)," ")
SET X=$PIECE(QAOSTEXT," ",1,QAOSWORD)
+6 SET ^QA(741,QAOSD0,"CMTE",QAOSD1,1,QAOSD2,0)=$$SPC(X)
+7 SET QAOSTEXT=$PIECE(QAOSTEXT," ",QAOSWORD+1,999)
+8 QUIT
End DoDot:2
if QAOSTEXT=""
QUIT
+9 SET ^QA(741,QAOSD0,"CMTE",QAOSD1,1,0)="^741.027^"_QAOSD2_"^"_QAOSD2
+10 SET $PIECE(^QA(741,QAOSD0,"CMTE",QAOSD1,0),"^",4)=""
+11 QUIT
End DoDot:1
+12 QUIT
SPC(X) ; REMOVE LEADING AND TRAILING SPACES
+1 NEW BEG,END
+2 FOR BEG=1:1
if $EXTRACT(X,BEG)'=" "
QUIT
+3 FOR END=$LENGTH(X):-1
if $EXTRACT(X,END)'=" "
QUIT
+4 QUIT $EXTRACT(X,BEG,END)
