AMQQEM2O.m

AMQQEM2O ; IHS/CMI/THL - FORMAT FLAT FILE SUBROUTINE ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ; This routine was extracted from AMQQEM2 to reducd the routine

 ; size to satisfy SAC requirements.  BRJ/IHS 6/4/93

 ; AMQQEM2 was changed at line L1+9 to D OTHER^AMQQEM2O 

 ; OTHER^AMQQEM2O - This is the only known call to the

 ; label OTHER in the AMQQ routine set

 ;-----

OTHER ; ENTRY POINT - FROM L1+9^AMQQEM2

 W !!!,"Only single valued demographic attributes allowed =>",!

 S DIC("A")="Attribute: "

 S DIC="^AMQQ(5,"

 S DIC(0)="AEQS"

 S DIC("S")="I $P(^(0),U,2)=AMQQCCLS,$P(^(0),U,5),'$P(^AMQQ(1,$P(^(0),U,5),0),U,7),Y'=265,Y'=112"

 S D="C"

 D IX^DIC

 K DIC

 I Y=-1,X="^^" S AMQQQUIT="" Q

 I Y=-1 S AMQQEMNO="" Q

 I $G(AMQQEMP)[(U_$P(Y,U,2)_U) W "  <= ALREADY ON THE MENU",*7 Q

 X "I 0"

 F %=0:0 S %=$O(^UTILITY("AMQQ",$J,"FLAT",%)) Q:'%  I +^(%,0)=+Y Q

 I  W !!,"This field has already been entered...Try again!",*7 H 2 S AMQQEMNO="" Q

 S C=C+1

 S %=$P(^AMQQ(5,+Y,0),U,5)

 S %=$P(^AMQQ(1,%,0),U,5)

 S @G@(C,0)=+Y_"^1^"_$E($P(Y,U,2),1,AMQQEM("HLEN"))_U_$S(%=7:"D",%=9:"N",1:"F")_"^^"_$E($P(Y,U,2),1,AMQQEM("HLEN"))_U_($G(AMQQEM("FIX"))+$G(AMQQEM("MLEN")))

 S @G@(C,2)=""

 S %=$G(^AMQQ(1,$P(^AMQQ(5,+Y,0),U,5),4,1,1))

 I %'="" S @G@(C,2)="I X'="""" "_%

 S A=$P(^AMQQ(1,$P(^AMQQ(5,+Y,0),U,5),0),U,3),B=$P(^(0),U,4)

 I B="" K @G@(C) S C=C-1 D  G OTHER

 .W !!,*7,"Sorry, this attribute is a ""multiple"".  This version of Q-Man does not",!,"allow adding multi-valued attributes after search criteria are defined."

 .W !,"To add this attribute, start over and include it in the search criteria."

 .K %,X,Z,A,B S Y=C

 S %=$P(^DD(A,B,0),U,4)

 S Z=^DIC(A,0,"GL")

 S Z=Z_"AMQP("_$S(AMQQCCLS="P":0,AMQQCCLS="V":1,1:5)_"),"""_$P(%,";")_""")"

 S @G@(C,1)="S X=$P($G("_Z_"),U,"_$P(%,";",2)_")"

 K %,X,Z,A,B

 S Y=C

 Q

 ;

AMQQEM2O  ; IHS/CMI/THL - FORMAT FLAT FILE SUBROUTINE ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ; This routine was extracted from AMQQEM2 to reducd the routine

 +3       ; size to satisfy SAC requirements.  BRJ/IHS 6/4/93

 +4       ; AMQQEM2 was changed at line L1+9 to D OTHER^AMQQEM2O 

 +5       ; OTHER^AMQQEM2O - This is the only known call to the

 +6       ; label OTHER in the AMQQ routine set

 +7       ;-----

OTHER     ; ENTRY POINT - FROM L1+9^AMQQEM2

 +1        WRITE !!!,"Only single valued demographic attributes allowed =>",!

 +2        SET DIC("A")="Attribute: "

 +3        SET DIC="^AMQQ(5,"

 +4        SET DIC(0)="AEQS"

 +5        SET DIC("S")="I $P(^(0),U,2)=AMQQCCLS,$P(^(0),U,5),'$P(^AMQQ(1,$P(^(0),U,5),0),U,7),Y'=265,Y'=112"

 +6        SET D="C"

 +7        DO IX^DIC

 +8        KILL DIC

 +9        IF Y=-1

               IF X="^^"

                   SET AMQQQUIT=""

                   QUIT 

 +10       IF Y=-1

               SET AMQQEMNO=""

               QUIT 

 +11       IF $GET(AMQQEMP)[(U_$PIECE(Y,U,2)_U)

               WRITE "  <= ALREADY ON THE MENU",*7

               QUIT 

 +12       XECUTE "I 0"

 +13       FOR %=0:0

               SET %=$ORDER(^UTILITY("AMQQ",$JOB,"FLAT",%))

               IF '%

                   QUIT 

               IF +^(%,0)=+Y

                   QUIT 

 +14      IF $TEST

               WRITE !!,"This field has already been entered...Try again!",*7

               HANG 2

               SET AMQQEMNO=""

               QUIT 

 +15       SET C=C+1

 +16       SET %=$PIECE(^AMQQ(5,+Y,0),U,5)

 +17       SET %=$PIECE(^AMQQ(1,%,0),U,5)

 +18       SET @G@(C,0)=+Y_"^1^"_$EXTRACT($PIECE(Y,U,2),1,AMQQEM("HLEN"))_U_$SELECT(%=7:"D",%=9:"N",1:"F")_"^^"_$EXTRACT($PIECE(Y,U,2),1,AMQQEM("HLEN"))_U_($GET(AMQQEM("FIX"))+$GET(AMQQEM("MLEN")))

 +19       SET @G@(C,2)=""

 +20       SET %=$GET(^AMQQ(1,$PIECE(^AMQQ(5,+Y,0),U,5),4,1,1))

 +21       IF %'=""

               SET @G@(C,2)="I X'="""" "_%

 +22       SET A=$PIECE(^AMQQ(1,$PIECE(^AMQQ(5,+Y,0),U,5),0),U,3)

           SET B=$PIECE(^(0),U,4)

 +23       IF B=""

               KILL @G@(C)

               SET C=C-1

               Begin DoDot:1

 +24               WRITE !!,*7,"Sorry, this attribute is a ""multiple"".  This version of Q-Man does not",!,"allow adding multi-valued attributes after search criteria are defined."

 +25               WRITE !,"To add this attribute, start over and include it in the search criteria."

 +26               KILL %,X,Z,A,B

                   SET Y=C

               End DoDot:1

               GOTO OTHER

 +27       SET %=$PIECE(^DD(A,B,0),U,4)

 +28       SET Z=^DIC(A,0,"GL")

 +29       SET Z=Z_"AMQP("_$SELECT(AMQQCCLS="P":0,AMQQCCLS="V":1,1:5)_"),"""_$PIECE(%,";")_""")"

 +30       SET @G@(C,1)="S X=$P($G("_Z_"),U,"_$PIECE(%,";",2)_")"

 +31       KILL %,X,Z,A,B

 +32       SET Y=C

 +33       QUIT 

 +34      ;