QAQAHOC5.m

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 ---QAQAHOC5   1741     printed  Feb 18, 2025@23:57:46                                                                                                                                                                                                    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