AUM93082.m

AUM93082 ; DSD/GTH - STANDARD TABLE UPDATES (2), 25AUG93 MEMO ; [ 08/26/93  12:15 PM ]

 ;;93.1;TABLE MAINTENANCE;**6**;MARCH 23, 1993

 ;

 Q

 ;

START ;EP

 ;

 NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T

 S E(0)="ERROR : ",E(1)="NOT ADDED : "

 D COMMNEW,COMMMOD

 Q

 ; ===   utility sub-routines   ====

 ;

ADDOK D RSLT(E_", Added : "_L) Q

ADDFAIL D RSLT(E(0)_E_" : ADD FAILED => "_L) Q

DIE NEW A,C,E,L,N,O,P,R,S,T

 LOCK +(@(DIE_DA_")")):10 E  D RSLT(E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q

 D ^DIE LOCK -(@(DIE_DA_")")) K DA,DIE,DR Q

FILE NEW A,C,E,L,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN K DIC Q

MODOK D RSLT(E_", Changed : "_L) Q

RSLT(%) S ^(0)=$G(^TMP($J,"RSLT",0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q

 ;

 ; =================================

 ;

COMMNEW ;

 S E="New Community Codes"

 F T=1:1 S L=$T(COMMNEW+T^AUM9308A) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDCOMM

 Q

 ;

ADDCOMM ;

 S L=$P(L,";;",2),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6),L=S_" "_O_" "_C_" "_N_" "_A_" "_V

 I $D(^AUTTCOM("C",S_O_C)) D RSLT(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C) Q

 S P("O")=$$IEN^AUM93081("^AUTTCTY(",S_O) Q:'P("O")

 S P("A")=$$IEN^AUM93081("^AUTTAREA(",A) Q:'P("A")

 S P("V")=$$IEN^AUM93081("^AUTTSU(",A_V) Q:'P("V")

 S DLAYGO=9999999.05,DIC="^AUTTCOM(",X=N,DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C D FILE

 D ADDFAIL:Y<0,ADDOK:Y>0

 Q

 ;

COMMMOD ;

 S E="Community Code Changes"

 F T=1:2 S L=$T(COMMMOD+T^AUM9308A) Q:$P(L,";",3)="END"  S L("TO")=$T(COMMMOD+T+1^AUM9308A) I $P(L("TO"),U,$L(L("TO"),U))="Y" D

 .S L=$P(L,U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3)

 .S P=$O(^AUTTCOM("C",S_O_C,0))

 .S L=$P(L("TO"),U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6)

 .I 'P S P=$O(^AUTTCOM("C",S_O_C,0)) I 'P S L=";;"_L D ADDCOMM Q

 .S L=S_" "_O_" "_C_" "_N_" "_A_" "_V

 .S P("O")=$$IEN^AUM93081("^AUTTCTY(",S_O) Q:'P("O")

 .S P("A")=$$IEN^AUM93081("^AUTTAREA(",A) Q:'P("A")

 .S P("V")=$$IEN^AUM93081("^AUTTSU(",A_V) Q:'P("V")

 .S DIE="^AUTTCOM(",DA=P,DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C D DIE

 .I $D(Y) D RSLT(E(0)_E_" : CHANGE FAILED => "_L) Q

 .D MODOK

 .Q

 Q

 ;

CLINNEW ;

 S E="New Clinic Codes"

 F T=1:1 S L=$T(CLINNEW+T^AUM9308A) Q:$P(L,";",3)="END"  I $P(L,U,$L(L,U))="Y" D ADDCLIN

 Q

 ;

ADDCLIN ;

 S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),L=C_" "_N

 I $D(^DIC(40.7,"C",C)) D RSLT(E(1)_E_" : CLINIC STOP CODE EXISTS => "_C) Q

 S DLAYGO=40.7,DIC="^DIC(40.7,",X=N,DIC("DR")="1///"_C D FILE

 D ADDFAIL:Y<0,ADDOK:Y>0

 Q

 ;

CLINMOD ;

 Q

 ;

AUM93082  ; DSD/GTH - STANDARD TABLE UPDATES (2), 25AUG93 MEMO ; [ 08/26/93  12:15 PM ]

 +1       ;;93.1;TABLE MAINTENANCE;**6**;MARCH 23, 1993

 +2       ;

 +3        QUIT 

 +4       ;

START     ;EP

 +1       ;

 +2        NEW A,C,DIC,DIE,DLAYGO,DR,E,L,N,O,P,R,S,T

 +3        SET E(0)="ERROR : "

           SET E(1)="NOT ADDED : "

 +4        DO COMMNEW

           DO COMMMOD

 +5        QUIT 

 +6       ; ===   utility sub-routines   ====

 +7       ;

ADDOK      DO RSLT(E_", Added : "_L)

           QUIT 

ADDFAIL    DO RSLT(E(0)_E_" : ADD FAILED => "_L)

           QUIT 

DIE        NEW A,C,E,L,N,O,P,R,S,T

 +1        LOCK +(@(DIE_DA_")")):10

          IF '$TEST

               DO RSLT(E(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.")

               SET Y=1

               QUIT 

 +2        DO ^DIE

           LOCK -(@(DIE_DA_")"))

           KILL DA,DIE,DR

           QUIT 

FILE       NEW A,C,E,L,N,O,P,R,S,T

           KILL DD,DO

           SET DIC(0)="L"

           DO FILE^DICN

           KILL DIC

           QUIT 

MODOK      DO RSLT(E_", Changed : "_L)

           QUIT 

RSLT(%)    SET ^(0)=$GET(^TMP($JOB,"RSLT",0))+1

           SET ^(^(0))=%

           IF '$DATA(ZTQUEUED)

               WRITE !,%

           QUIT 

 +1       ;

 +2       ; =================================

 +3       ;

COMMNEW   ;

 +1        SET E="New Community Codes"

 +2        FOR T=1:1

               SET L=$TEXT(COMMNEW+T^AUM9308A)

               IF $PIECE(L,";",3)="END"

                   QUIT 

               IF $PIECE(L,U,$LENGTH(L,U))="Y"

                   DO ADDCOMM

 +3        QUIT 

 +4       ;

ADDCOMM   ;

 +1        SET L=$PIECE(L,";;",2)

           SET S=$PIECE(L,U)

           SET O=$PIECE(L,U,2)

           SET C=$PIECE(L,U,3)

           SET N=$PIECE(L,U,4)

           SET A=$PIECE(L,U,5)

           SET V=$PIECE(L,U,6)

           SET L=S_" "_O_" "_C_" "_N_" "_A_" "_V

 +2        IF $DATA(^AUTTCOM("C",S_O_C))

               DO RSLT(E(1)_E_" : STCTYCOM CODE EXISTS => "_S_O_C)

               QUIT 

 +3        SET P("O")=$$IEN^AUM93081("^AUTTCTY(",S_O)

           IF 'P("O")

               QUIT 

 +4        SET P("A")=$$IEN^AUM93081("^AUTTAREA(",A)

           IF 'P("A")

               QUIT 

 +5        SET P("V")=$$IEN^AUM93081("^AUTTSU(",A_V)

           IF 'P("V")

               QUIT 

 +6        SET DLAYGO=9999999.05

           SET DIC="^AUTTCOM("

           SET X=N

           SET DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C

           DO FILE

 +7        IF Y<0

               DO ADDFAIL

           IF Y>0

               DO ADDOK

 +8        QUIT 

 +9       ;

COMMMOD   ;

 +1        SET E="Community Code Changes"

 +2        FOR T=1:2

               SET L=$TEXT(COMMMOD+T^AUM9308A)

               IF $PIECE(L,";",3)="END"

                   QUIT 

               SET L("TO")=$TEXT(COMMMOD+T+1^AUM9308A)

               IF $PIECE(L("TO"),U,$LENGTH(L("TO"),U))="Y"

                   Begin DoDot:1

 +3                    SET L=$PIECE(L,U,2,99)

                       SET S=$PIECE(L,U)

                       SET O=$PIECE(L,U,2)

                       SET C=$PIECE(L,U,3)

 +4                    SET P=$ORDER(^AUTTCOM("C",S_O_C,0))

 +5                    SET L=$PIECE(L("TO"),U,2,99)

                       SET S=$PIECE(L,U)

                       SET O=$PIECE(L,U,2)

                       SET C=$PIECE(L,U,3)

                       SET N=$PIECE(L,U,4)

                       SET A=$PIECE(L,U,5)

                       SET V=$PIECE(L,U,6)

 +6                    IF 'P

                           SET P=$ORDER(^AUTTCOM("C",S_O_C,0))

                           IF 'P

                               SET L=";;"_L

                               DO ADDCOMM

                               QUIT 

 +7                    SET L=S_" "_O_" "_C_" "_N_" "_A_" "_V

 +8                    SET P("O")=$$IEN^AUM93081("^AUTTCTY(",S_O)

                       IF 'P("O")

                           QUIT 

 +9                    SET P("A")=$$IEN^AUM93081("^AUTTAREA(",A)

                       IF 'P("A")

                           QUIT 

 +10                   SET P("V")=$$IEN^AUM93081("^AUTTSU(",A_V)

                       IF 'P("V")

                           QUIT 

 +11                   SET DIE="^AUTTCOM("

                       SET DA=P

                       SET DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C

                       DO DIE

 +12                   IF $DATA(Y)

                           DO RSLT(E(0)_E_" : CHANGE FAILED => "_L)

                           QUIT 

 +13                   DO MODOK

 +14                   QUIT 

                   End DoDot:1

 +15       QUIT 

 +16      ;

CLINNEW   ;

 +1        SET E="New Clinic Codes"

 +2        FOR T=1:1

               SET L=$TEXT(CLINNEW+T^AUM9308A)

               IF $PIECE(L,";",3)="END"

                   QUIT 

               IF $PIECE(L,U,$LENGTH(L,U))="Y"

                   DO ADDCLIN

 +3        QUIT 

 +4       ;

ADDCLIN   ;

 +1        SET L=$PIECE(L,";;",2)

           SET C=$PIECE(L,U)

           SET N=$PIECE(L,U,2)

           SET L=C_" "_N

 +2        IF $DATA(^DIC(40.7,"C",C))

               DO RSLT(E(1)_E_" : CLINIC STOP CODE EXISTS => "_C)

               QUIT 

 +3        SET DLAYGO=40.7

           SET DIC="^DIC(40.7,"

           SET X=N

           SET DIC("DR")="1///"_C

           DO FILE

 +4        IF Y<0

               DO ADDFAIL

           IF Y>0

               DO ADDOK

 +5        QUIT 

 +6       ;

CLINMOD   ;

 +1        QUIT 

 +2       ;