QAQAHOC5 ;WCIOFO/ERC-Continuation of QAQAHOC3 ;7/22/98
;;1.7;QM Integration Module;**5**;07/25/1995
;
EDITMAC ;if the macro is not valid, display message explaining that user
;should enter the macro again, then either use the same name to
;replace the old macro with the current, valid one, or to use a
;new name.
W !!,"Your macro is no longer valid. Re-enter the macro now, and"
W !,"when finished enter '[S' to save it at the prompt for the next"
W !,"field. Enter the old macro name if you want to replace it with"
W !,"the new criteria, or enter a completely new name."
S DIR(0)="E" D ^DIR K DIR
S Y=0
Q
STRIP ;if there are qualifiers on QAQFLD,strip them off
N X
S QAQFLD1=""
F X=1:1:$L(QAQFLD) I "'!@#&+-"[$E(QAQFLD) S QAQFLD1=QAQFLD1_$E(QAQFLD),QAQFLD=$E(QAQFLD,2,999)
Q
STRIP2 ;if there are qualifiers on QAQPF, strip them out before comparing
;to QAQPM
N QAQFIRST,QAQLAST,QAQLNTH,QAQPFQUL,X
S QAQPFQUL=""
S (QAQCC,QAQFIRST)=0
S QAQPFX=QAQPF
F X=1:1:$L(QAQPFX) S:"'!@#&+-"[$E(QAQPFX) QAQLNTH(X)=X,QAQPFQUL=QAQPFQUL_$E(QAQPF,X) S QAQPFX=$E(QAQPFX,2,999)
S QAQPM=$TR(QAQPM,"~")
I $G(QAQPFQUL)]"" D
. F S QAQCC=$O(QAQLNTH(QAQCC)) Q:QAQCC'>0 S:$G(QAQFIRST)<1 QAQFIRST=QAQCC S QAQLAST=QAQCC
. I $G(QAQFIRST)>0 D
. . S QAQPF1=$E(QAQPF,1,QAQFIRST-1)
. . S QAQPF2=$E(QAQPF,QAQLAST+1,999)
. . I $G(QAQPM)'=($G(QAQPF1)_$G(QAQPF2)) S QAQPF1=$G(QAQPM1),QAQPF2=$G(QAQPM2)
. . S QAQPFALL=$G(QAQPF1)_$G(QAQPFQUL)_$G(QAQPF2)
. . I $G(QAQPFEND)]"" S QAQPFALL=$G(QAQPFALL)_";"_$G(QAQPFEND)
I $G(QAQPFQUL)']"" D
. I $G(QAQPF)'=$G(QAQPM) S QAQPF=$G(QAQPM)
. S QAQPFALL=$G(QAQPF)_$S($G(QAQPFEND)]"":";"_QAQPFEND,1:"")
S $P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2)=$G(QAQPFALL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOC5 1741 printed Dec 13, 2024@02:31:15 Page 2
QAQAHOC5 ;WCIOFO/ERC-Continuation of QAQAHOC3 ;7/22/98
+1 ;;1.7;QM Integration Module;**5**;07/25/1995
+2 ;
EDITMAC ;if the macro is not valid, display message explaining that user
+1 ;should enter the macro again, then either use the same name to
+2 ;replace the old macro with the current, valid one, or to use a
+3 ;new name.
+4 WRITE !!,"Your macro is no longer valid. Re-enter the macro now, and"
+5 WRITE !,"when finished enter '[S' to save it at the prompt for the next"
+6 WRITE !,"field. Enter the old macro name if you want to replace it with"
+7 WRITE !,"the new criteria, or enter a completely new name."
+8 SET DIR(0)="E"
DO ^DIR
KILL DIR
+9 SET Y=0
+10 QUIT
STRIP ;if there are qualifiers on QAQFLD,strip them off
+1 NEW X
+2 SET QAQFLD1=""
+3 FOR X=1:1:$LENGTH(QAQFLD)
IF "'!@#&+-"[$EXTRACT(QAQFLD)
SET QAQFLD1=QAQFLD1_$EXTRACT(QAQFLD)
SET QAQFLD=$EXTRACT(QAQFLD,2,999)
+4 QUIT
STRIP2 ;if there are qualifiers on QAQPF, strip them out before comparing
+1 ;to QAQPM
+2 NEW QAQFIRST,QAQLAST,QAQLNTH,QAQPFQUL,X
+3 SET QAQPFQUL=""
+4 SET (QAQCC,QAQFIRST)=0
+5 SET QAQPFX=QAQPF
+6 FOR X=1:1:$LENGTH(QAQPFX)
if "'!@#&+-"[$EXTRACT(QAQPFX)
SET QAQLNTH(X)=X
SET QAQPFQUL=QAQPFQUL_$EXTRACT(QAQPF,X)
SET QAQPFX=$EXTRACT(QAQPFX,2,999)
+7 SET QAQPM=$TRANSLATE(QAQPM,"~")
+8 IF $GET(QAQPFQUL)]""
Begin DoDot:1
+9 FOR
SET QAQCC=$ORDER(QAQLNTH(QAQCC))
if QAQCC'>0
QUIT
if $GET(QAQFIRST)<1
SET QAQFIRST=QAQCC
SET QAQLAST=QAQCC
+10 IF $GET(QAQFIRST)>0
Begin DoDot:2
+11 SET QAQPF1=$EXTRACT(QAQPF,1,QAQFIRST-1)
+12 SET QAQPF2=$EXTRACT(QAQPF,QAQLAST+1,999)
+13 IF $GET(QAQPM)'=($GET(QAQPF1)_$GET(QAQPF2))
SET QAQPF1=$GET(QAQPM1)
SET QAQPF2=$GET(QAQPM2)
+14 SET QAQPFALL=$GET(QAQPF1)_$GET(QAQPFQUL)_$GET(QAQPF2)
+15 IF $GET(QAQPFEND)]""
SET QAQPFALL=$GET(QAQPFALL)_";"_$GET(QAQPFEND)
End DoDot:2
End DoDot:1
+16 IF $GET(QAQPFQUL)']""
Begin DoDot:1
+17 IF $GET(QAQPF)'=$GET(QAQPM)
SET QAQPF=$GET(QAQPM)
+18 SET QAQPFALL=$GET(QAQPF)_$SELECT($GET(QAQPFEND)]"":";"_QAQPFEND,1:"")
End DoDot:1
+19 SET $PIECE(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2)=$GET(QAQPFALL)
+20 QUIT
