- 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 Feb 18, 2025@23:47:45 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)