AMQQEM31.m

AMQQEM31 ; IHS/CMI/THL - AMQQEM3 OVERFLOW ;

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

 ;-----

T5 ; EP FROM AMQQEM3 ; THIS SUBROUTINE HAS BEEN MOVED FROM AMQQEM3

 S %=$$KEYCHECK^AMQQUTIL("AMQQZPROG")

 I '% W !,"Sorry.  This option requires a Q-Man Programmer Access Key.  Check with your site manager.",!!,*7 H 2 Q

 W "MUMPS TRANSFORM",!

 I '$D(@G@(AMQQEMN,3)) G T51

 W *7,"This field already has the following transform: "

 W !,@G@(AMQQEMN,3)

 S DIR(0)="S^R:REPLACE THE OLD TRANSFORM WITH A NEW ONE;D:DELETE THE TRANSFORM"

 S DIR("A")="     Your choice"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I "^"[X Q

 I X?2."?" S AMQQQUIT="" Q

 I Y="D" K @G@(AMQQEMN,3) Q

T51 D DIR^AMQQEM31

 S DIR(0)="FO^:"

 S DIR("A")="Enter MUMPS code"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I "^"[X Q

 I X="^^" S AMQQQUIT="" Q

 D ^DIM

 I '$D(X) W "  ??",*7 Q

 S @G@(AMQQEMN,3)=X

 Q

 ;

T6 ; EP FROM AMQQEM3

 W "CHANGE FIELD LENGTH",!

 W "Current field length: ",$S($D(AMQQFLEN):AMQQFLEN,'$P(@G@(AMQQEMN,0),U,7):AMQQEM("FIX"),1:$P(@G@(AMQQEMN,0),U,7))

 S DIR(0)="NO"

 S DIR("A")="New field length"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I "^"[X Q

 I X?2."^" S AMQQQUIT="" Q

 I $D(AMQQFLEN) S AMQQFLEN=Y

 S $P(@G@(AMQQEMN,0),U,7)=Y

 Q

 ;

T8 ; EP FROM AMQQEM3

 W "USE QUOTATION MARKS",!

 S DIR(0)="Y"

 S DIR("A")="Sure you want to put quotation marks around each entry in the field"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I X=U!('Y) Q

 I X?2.U S AMQQQUIT="" Q

 S %=$G(@G@(1,2))

 S:%'="" %=%_" "

 S %=%_"S X=$C(34)_X_$C(34)"

 S @G@(1,2)=%

 Q

 ;

T7 ; EP FROM AMQQEM3

 W "SUBSTITUTE FOR DELIMITER CHARACTER",!

S1 S DIR(0)="F^:"

 S DIR("A")="Enter the substitute character for the PATIENT NAME field"

 S DIR("?")="Must be 1 'punctuation' character such as '_' or ';'"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I $D(DIRUT)!$D(DTOUT) K DTOUT,DIRUT,DIROUT,DUOUT

 I X=U Q

 I X?2."^" S AMQQQUIT="" Q

 I Y'?1P!(Y=",") W "  ??",*7 G S1

 S %=$G(@G@(1,2))

 S:%'="" %=%_" "

 S %=%_"S X=$P(X,"","")_"""_Y_"""_$P(X,"","",2)"

 S @G@(1,2)=%

 Q

 ;

DIR ; -ENTRY POINT - DIR SETUP FROM T51^AMQQEM3 (OVERFLOW FROM THAT RTN)

 S DIR("?")="Enter the MUMPS code which will transform the value of the field/variable.  When the MUMPS code is executed, the variable ""X"" will contain the value to be transformed; e.g., S X=$P(X,"","",1)"

 Q

 ;

FLEN ; EP FROM AMQQEM3 ; FIELD LENGTH

 I $D(AMQQFEDT) Q

 N Y,I,N,%,T,A,B,C

 S %=$P(AMQQEMFS,(U_AMQQEMN_U))

 S A=0

 F I=1:1 S B=$P(%,U,I) Q:B=""  S A=A+$P(^UTILITY("AMQQ",$J,"FLAT",B,0),U,7)+1

 S %=AMQQEM("LEN")-A

 S C=$S(%>AMQQEM("MLEN"):AMQQEM("MLEN"),1:%)

 I C<1 W !!,"Sorry, no more room!  You must edit a previously selected field or quit",*7,!! S AMQQSTOP=U H 3 Q

FLEN1 W !!

 S DIR(0)="NO^1:"_C

 S DIR("A")="Enter the length of this field"

 S DIR("?")="Must not exceed maximum field length"

 D ^DIR

 K DIR

 S:$D(DUOUT) DIRUT=1

 I Y?2."^" S AMQQQUIT="" Q

 I Y=U S AMQQSTOP="" Q

 I 'Y W "  ??",*7 G FLEN

 S T=Y

 S N=0

 F  S N=$O(H(N)) Q:'N  F I=1:1 S %=$P(H(N),U,I) Q:%=""  S T=$P(%,";",2)+T

 I T>AMQQEM("LEN") W "  ??",*7,!!,"Sorry, you have exceeded the maximum field length...Try again!",!! K AMQQFLEN G FLEN1

 S AMQQFLEN=+Y

 S $P(@G@(AMQQEMN,0),U,7)=AMQQFLEN

 Q

 ;

AMQQEM31  ; IHS/CMI/THL - AMQQEM3 OVERFLOW ;

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

 +2       ;-----

T5        ; EP FROM AMQQEM3 ; THIS SUBROUTINE HAS BEEN MOVED FROM AMQQEM3

 +1        SET %=$$KEYCHECK^AMQQUTIL("AMQQZPROG")

 +2        IF '%

               WRITE !,"Sorry.  This option requires a Q-Man Programmer Access Key.  Check with your site manager.",!!,*7

               HANG 2

               QUIT 

 +3        WRITE "MUMPS TRANSFORM",!

 +4        IF '$DATA(@G@(AMQQEMN,3))

               GOTO T51

 +5        WRITE *7,"This field already has the following transform: "

 +6        WRITE !,@G@(AMQQEMN,3)

 +7        SET DIR(0)="S^R:REPLACE THE OLD TRANSFORM WITH A NEW ONE;D:DELETE THE TRANSFORM"

 +8        SET DIR("A")="     Your choice"

 +9        DO ^DIR

 +10       KILL DIR

 +11       IF $DATA(DUOUT)

               SET DIRUT=1

 +12       IF "^"[X

               QUIT 

 +13       IF X?2."?"

               SET AMQQQUIT=""

               QUIT 

 +14       IF Y="D"

               KILL @G@(AMQQEMN,3)

               QUIT 

T51        DO DIR^AMQQEM31

 +1        SET DIR(0)="FO^:"

 +2        SET DIR("A")="Enter MUMPS code"

 +3        DO ^DIR

 +4        KILL DIR

 +5        IF $DATA(DUOUT)

               SET DIRUT=1

 +6        IF "^"[X

               QUIT 

 +7        IF X="^^"

               SET AMQQQUIT=""

               QUIT 

 +8        DO ^DIM

 +9        IF '$DATA(X)

               WRITE "  ??",*7

               QUIT 

 +10       SET @G@(AMQQEMN,3)=X

 +11       QUIT 

 +12      ;

T6        ; EP FROM AMQQEM3

 +1        WRITE "CHANGE FIELD LENGTH",!

 +2        WRITE "Current field length: ",$SELECT($DATA(AMQQFLEN):AMQQFLEN,'$PIECE(@G@(AMQQEMN,0),U,7):AMQQEM("FIX"),1:$PIECE(@G@(AMQQEMN,0),U,7))

 +3        SET DIR(0)="NO"

 +4        SET DIR("A")="New field length"

 +5        DO ^DIR

 +6        KILL DIR

 +7        IF $DATA(DUOUT)

               SET DIRUT=1

 +8        IF "^"[X

               QUIT 

 +9        IF X?2."^"

               SET AMQQQUIT=""

               QUIT 

 +10       IF $DATA(AMQQFLEN)

               SET AMQQFLEN=Y

 +11       SET $PIECE(@G@(AMQQEMN,0),U,7)=Y

 +12       QUIT 

 +13      ;

T8        ; EP FROM AMQQEM3

 +1        WRITE "USE QUOTATION MARKS",!

 +2        SET DIR(0)="Y"

 +3        SET DIR("A")="Sure you want to put quotation marks around each entry in the field"

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DUOUT)

               SET DIRUT=1

 +7        IF X=U!('Y)

               QUIT 

 +8        IF X?2.U

               SET AMQQQUIT=""

               QUIT 

 +9        SET %=$GET(@G@(1,2))

 +10       IF %'=""

               SET %=%_" "

 +11       SET %=%_"S X=$C(34)_X_$C(34)"

 +12       SET @G@(1,2)=%

 +13       QUIT 

 +14      ;

T7        ; EP FROM AMQQEM3

 +1        WRITE "SUBSTITUTE FOR DELIMITER CHARACTER",!

S1         SET DIR(0)="F^:"

 +1        SET DIR("A")="Enter the substitute character for the PATIENT NAME field"

 +2        SET DIR("?")="Must be 1 'punctuation' character such as '_' or ';'"

 +3        DO ^DIR

 +4        KILL DIR

 +5        IF $DATA(DUOUT)

               SET DIRUT=1

 +6        IF $DATA(DIRUT)!$DATA(DTOUT)

               KILL DTOUT,DIRUT,DIROUT,DUOUT

 +7        IF X=U

               QUIT 

 +8        IF X?2."^"

               SET AMQQQUIT=""

               QUIT 

 +9        IF Y'?1P!(Y=",")

               WRITE "  ??",*7

               GOTO S1

 +10       SET %=$GET(@G@(1,2))

 +11       IF %'=""

               SET %=%_" "

 +12       SET %=%_"S X=$P(X,"","")_"""_Y_"""_$P(X,"","",2)"

 +13       SET @G@(1,2)=%

 +14       QUIT 

 +15      ;

DIR       ; -ENTRY POINT - DIR SETUP FROM T51^AMQQEM3 (OVERFLOW FROM THAT RTN)

 +1        SET DIR("?")="Enter the MUMPS code which will transform the value of the field/variable.  When the MUMPS code is executed, the variable ""X"" will contain the value to be transformed; e.g., S X=$P(X,"","",1)"

 +2        QUIT 

 +3       ;

FLEN      ; EP FROM AMQQEM3 ; FIELD LENGTH

 +1        IF $DATA(AMQQFEDT)

               QUIT 

 +2        NEW Y,I,N,%,T,A,B,C

 +3        SET %=$PIECE(AMQQEMFS,(U_AMQQEMN_U))

 +4        SET A=0

 +5        FOR I=1:1

               SET B=$PIECE(%,U,I)

               IF B=""

                   QUIT 

               SET A=A+$PIECE(^UTILITY("AMQQ",$JOB,"FLAT",B,0),U,7)+1

 +6        SET %=AMQQEM("LEN")-A

 +7        SET C=$SELECT(%>AMQQEM("MLEN"):AMQQEM("MLEN"),1:%)

 +8        IF C<1

               WRITE !!,"Sorry, no more room!  You must edit a previously selected field or quit",*7,!!

               SET AMQQSTOP=U

               HANG 3

               QUIT 

FLEN1      WRITE !!

 +1        SET DIR(0)="NO^1:"_C

 +2        SET DIR("A")="Enter the length of this field"

 +3        SET DIR("?")="Must not exceed maximum field length"

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DUOUT)

               SET DIRUT=1

 +7        IF Y?2."^"

               SET AMQQQUIT=""

               QUIT 

 +8        IF Y=U

               SET AMQQSTOP=""

               QUIT 

 +9        IF 'Y

               WRITE "  ??",*7

               GOTO FLEN

 +10       SET T=Y

 +11       SET N=0

 +12       FOR 

               SET N=$ORDER(H(N))

               IF 'N

                   QUIT 

               FOR I=1:1

                   SET %=$PIECE(H(N),U,I)

                   IF %=""

                       QUIT 

                   SET T=$PIECE(%,";",2)+T

 +13       IF T>AMQQEM("LEN")

               WRITE "  ??",*7,!!,"Sorry, you have exceeded the maximum field length...Try again!",!!

               KILL AMQQFLEN

               GOTO FLEN1

 +14       SET AMQQFLEN=+Y

 +15       SET $PIECE(@G@(AMQQEMN,0),U,7)=AMQQFLEN

 +16       QUIT 

 +17      ;