Routine: ACDCSD

ACDCSD ;IHS/ADC/EDE/KML - DATA ENTER/EDIT FOR CLIENT CATEGORIES;

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

START ;

 D MAIN

 D EOJ

MAIN ;

 D INIT

 Q:ACDQ

 D GETCAT

 Q:ACDQ

 I ACDNEWG S Y=1 I 1

 E  S DIR(0)="S^1:Add new patients;2:Delete existing patients",DIR("A")="Choose",DIR("B")="1" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S ACDAE=Y

 F  D GETPATS Q:ACDQ

INIT ;

 S ACDQ=1

 Q:'$D(IOF)

 Q:'$G(DUZ(2))

 Q:'$D(^ACDF5PI(DUZ(2),0))  ;   should never happen

 S ACDPGM=DUZ(2)

 Q:'$G(IO)

 S Y=$O(^%ZIS(1,"C",IO,0)) I Y S Y=$P($G(^%ZIS(1,Y,"SUBTYPE")),U) I Y S X=$G(^%ZIS(2,Y,5)),ACDRVON=$P(X,U,4),ACDRVOF=$P(X,U,5)

 I $G(ACDRVON)="" S ACDRVON="""""",ACDRVOF=""""""

 S ACDDUZZ=DUZ(2)

 S ACDDOV=DT ;                  set visit date for ^ACDAGRG

 K ^TMP("ACD",$J),^TMP($J)

 S ACDDUZZ=DUZ(2)

 W @IOF,"Signon Program is            : ",$P(^DIC(4,DUZ(2),0),U)

 W !,"Adding/editing client categories for auto cs duplication",!

 S ACDQ=0

GETCAT ; GET CLIENT CATEGORY

 S ACDQ=1

 S DIC="^ACDPAT(",DIC(0)="AEMQL",DLAYGO=9002172.8,DIC("DR")="2////"_ACDPGM_";.03;.04",DIC("S")="I $P(^(0),U,2)=ACDPGM" D DIC^ACDFMC

 Q:Y<0

 S ACDCC=+Y

 S ACDNEWG=+$P(Y,U,3)

 I '$P(Y,U,3) S DIE="^ACDPAT(",DA=+Y,DR=".01" S ACDKPDA=1 D DIE^ACDFMC I '$D(DA) Q  ;         user must have deleted the client category

 K DA

 S ACDCOMC=$P(^ACDPAT(ACDCC,0),U,3),ACDCOMT=$P(^(0),U,4)

 S Y=ACDCOMC,C=$P(^DD(9002172.8,.03,0),U,2) D Y^DIQ S ACDCOMCL=Y

 S Y=ACDCOMT,C=$P(^DD(9002172.8,.04,0),U,2) D Y^DIQ S ACDCOMTL=Y

 I ACDCOMC=""!(ACDCOMT="") D FIXCAT Q:ACDQ

 I $O(^ACDPAT(ACDCC,1,0)) S DIC="^ACDPAT(",DA=ACDCC D DIQ^ACDFMC,PAUSE^ACDDEU

 S ACDQ=0

FIXCAT ; FIX OLD CATEGORY.  IT MUST HAVE COMC/COMT

 S ACDQ=0

 S DIE="^ACDPAT("

 S DA=ACDCC

 S DR=".03;.04"

 D DIE^ACDFMC

 S ACDCOMC=$P(^ACDPAT(ACDCC,0),U,3),ACDCOMT=$P(^(0),U,4)

 I ACDCOMC=""!(ACDCOMT="") S ACDQ=1 Q

 S Y=ACDCOMC,C=$P(^DD(9002172.8,.03,0),U,2) D Y^DIQ S ACDCOMCL=Y

 S Y=ACDCOMT,C=$P(^DD(9002172.8,.04,0),U,2) D Y^DIQ S ACDCOMTL=Y

 ; now make sure all patients in category have init for comc/comt

 S ACDY=0 F  S ACDY=$O(^ACDPAT(ACDCC,1,ACDY)) Q:'ACDY  S ACDDFNP=+^(ACDY,0) D

 . S ACDDFN=$P(^DPT(ACDDFNP,0),U) ;     get patient name

 . S ACDINR=1

 . NEW ACDY

 . D CHKFIN^ACDDEU ;       check for initial type contact

. Q

 I ACDQ W !!,"WARNING - All patients must have an initial type contact for the",!,ACDCOMCL,"/",ACDCOMTL," component prior to using this client category,",!

GETPATS ; GET PATIENTS

 K ACDNEWP

 I ACDAE=2 D PATED Q

 D ^ACDDEGP

 Q:ACDQ

 D GETVSITS^ACDDEU ;       gather up all visits for this patient

 I $D(^ACDPAT(ACDCC,1,ACDDFNP,0)) D EDIT Q

 ; add a new patient

 S ACDINR=1

 D CHKFIN^ACDDEU ;         check for initial type contact

 I ACDQ S ACDQ=0 Q

 S DIC="^ACDPAT("_ACDCC_",1,"

 S DIC(0)="L"

 S DIC("P")=$P(^DD(9002172.8,1,0),U,2)

 S DA=ACDDFNP,DA(1)=ACDCC

 S DINUM=DA

 S X=ACDDFNP

 D FILE^ACDFMC

 I +Y<0 W !,"Creation of CLIENT entry failed.  Notify programmer.",!! S ACDQ=1 S:$D(^%ZOSF("$ZE")) X="CDMIS CLIENT CATEGORY CLIENT",@^("$ZE") D @^%ZOSF("ERRTN") Q

 S ACDNEWP=1

 D EDIT

PATED ; SELECT AN EXISTING PATIENT TO EDIT

W !

 S DIC="^ACDPAT(ACDCC,1,",DIC(0)="AEMQ" D ^DIC

 I Y<0 S ACDQ=1 Q

 S ACDDFNP=+Y

 S ACDDFN=$P(^DPT(ACDDFNP,0),U)

 D GETDEMO^ACDDEGP

 D EDIT

EDIT ; EDIT AN EXISTING PATIENT

 S DIE="^ACDPAT("_ACDCC_",1,"

 S DA=ACDDFNP,DA(1)=ACDCC

 S DR=""

 S:'$G(ACDNEWP) DR=".01//"_ACDDFN_";"

 S DR=DR_"2////"_ACDTRBCD_";3////"_ACDSEX_";4////"_ACDAGER_";22////"_ACDSTACD_";23////"_ACDSTA_";24////"_ACDTRB_";25////"_ACDVET_";26////"_ACDAGE

 D DIE^ACDFMC

 W !,"  Patient demographic information set from Patient Registration data."

EOJ ;

 K ACDNEWG

 D ^ACDKILL

ACDCSD    ;IHS/ADC/EDE/KML - DATA ENTER/EDIT FOR CLIENT CATEGORIES;

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 +2       ;

START     ;

 +1        DO MAIN

 +2        DO EOJ

 +3        QUIT

 +4       ;

MAIN      ;

 +1        DO INIT

 +2        IF ACDQ

               QUIT

 +3        DO GETCAT

 +4        IF ACDQ

               QUIT

 +5        IF ACDNEWG

               SET Y=1

               IF 1

 +6       IF '$TEST

               SET DIR(0)="S^1:Add new patients;2:Delete existing patients"

               SET DIR("A")="Choose"

               SET DIR("B")="1"

               KILL DA

               DO ^DIR

               KILL DIR

 +7        IF $DATA(DIRUT)

               QUIT

 +8        SET ACDAE=Y

 +9        FOR

               DO GETPATS

               IF ACDQ

                   QUIT

 +10       QUIT

 +11      ;

INIT      ;

 +1        SET ACDQ=1

 +2        IF '$DATA(IOF)

               QUIT

 +3        IF '$GET(DUZ(2))

               QUIT

 +4       ;   should never happen

           IF '$DATA(^ACDF5PI(DUZ(2),0))

               QUIT

 +5        SET ACDPGM=DUZ(2)

 +6        IF '$GET(IO)

               QUIT

 +7        SET Y=$ORDER(^%ZIS(1,"C",IO,0))

           IF Y

               SET Y=$PIECE($GET(^%ZIS(1,Y,"SUBTYPE")),U)

               IF Y

                   SET X=$GET(^%ZIS(2,Y,5))

                   SET ACDRVON=$PIECE(X,U,4)

                   SET ACDRVOF=$PIECE(X,U,5)

 +8        IF $GET(ACDRVON)=""

               SET ACDRVON=""""""

               SET ACDRVOF=""""""

 +9        SET ACDDUZZ=DUZ(2)

 +10      ;                  set visit date for ^ACDAGRG

           SET ACDDOV=DT

 +11       KILL ^TMP("ACD",$JOB),^TMP($JOB)

 +12       SET ACDDUZZ=DUZ(2)

 +13       WRITE @IOF,"Signon Program is            : ",$PIECE(^DIC(4,DUZ(2),0),U)

 +14       WRITE !,"Adding/editing client categories for auto cs duplication",!

 +15       SET ACDQ=0

 +16       QUIT

 +17      ;

GETCAT    ; GET CLIENT CATEGORY

 +1        SET ACDQ=1

 +2        SET DIC="^ACDPAT("

           SET DIC(0)="AEMQL"

           SET DLAYGO=9002172.8

           SET DIC("DR")="2////"_ACDPGM_";.03;.04"

           SET DIC("S")="I $P(^(0),U,2)=ACDPGM"

           DO DIC^ACDFMC

 +3        IF Y<0

               QUIT

 +4        SET ACDCC=+Y

 +5        SET ACDNEWG=+$PIECE(Y,U,3)

 +6       ;         user must have deleted the client category

           IF '$PIECE(Y,U,3)

               SET DIE="^ACDPAT("

               SET DA=+Y

               SET DR=".01"

               SET ACDKPDA=1

               DO DIE^ACDFMC

               IF '$DATA(DA)

                   QUIT

 +7        KILL DA

 +8        SET ACDCOMC=$PIECE(^ACDPAT(ACDCC,0),U,3)

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

 +9        SET Y=ACDCOMC

           SET C=$PIECE(^DD(9002172.8,.03,0),U,2)

           DO Y^DIQ

           SET ACDCOMCL=Y

 +10       SET Y=ACDCOMT

           SET C=$PIECE(^DD(9002172.8,.04,0),U,2)

           DO Y^DIQ

           SET ACDCOMTL=Y

 +11       IF ACDCOMC=""!(ACDCOMT="")

               DO FIXCAT

               IF ACDQ

                   QUIT

 +12       IF $ORDER(^ACDPAT(ACDCC,1,0))

               SET DIC="^ACDPAT("

               SET DA=ACDCC

               DO DIQ^ACDFMC

               DO PAUSE^ACDDEU

 +13       SET ACDQ=0

 +14       QUIT

 +15      ;

FIXCAT    ; FIX OLD CATEGORY.  IT MUST HAVE COMC/COMT

 +1        SET ACDQ=0

 +2        SET DIE="^ACDPAT("

 +3        SET DA=ACDCC

 +4        SET DR=".03;.04"

 +5        DO DIE^ACDFMC

 +6        SET ACDCOMC=$PIECE(^ACDPAT(ACDCC,0),U,3)

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

 +7        IF ACDCOMC=""!(ACDCOMT="")

               SET ACDQ=1

               QUIT

 +8        SET Y=ACDCOMC

           SET C=$PIECE(^DD(9002172.8,.03,0),U,2)

           DO Y^DIQ

           SET ACDCOMCL=Y

 +9        SET Y=ACDCOMT

           SET C=$PIECE(^DD(9002172.8,.04,0),U,2)

           DO Y^DIQ

           SET ACDCOMTL=Y

 +10      ; now make sure all patients in category have init for comc/comt

 +11       SET ACDY=0

FOR

               SET ACDY=$ORDER(^ACDPAT(ACDCC,1,ACDY))

               IF 'ACDY

                   QUIT

               SET ACDDFNP=+^(ACDY,0)

               Begin DoDot:1

 +12      ;     get patient name

                   SET ACDDFN=$PIECE(^DPT(ACDDFNP,0),U)

 +13               SET ACDINR=1

 +14               NEW ACDY

 +15      ;       check for initial type contact

                   DO CHKFIN^ACDDEU

 +16               QUIT

               End DoDot:1

 +17       IF ACDQ

               WRITE !!,"WARNING - All patients must have an initial type contact for the",!,ACDCOMCL,"/",ACDCOMTL," component prior to using this client category,",!

 +18       QUIT

 +19      ;

GETPATS   ; GET PATIENTS

 +1        KILL ACDNEWP

 +2        IF ACDAE=2

               DO PATED

               QUIT

 +3        DO ^ACDDEGP

 +4        IF ACDQ

               QUIT

 +5       ;       gather up all visits for this patient

           DO GETVSITS^ACDDEU

 +6        IF $DATA(^ACDPAT(ACDCC,1,ACDDFNP,0))

               DO EDIT

               QUIT

 +7       ; add a new patient

 +8        SET ACDINR=1

 +9       ;         check for initial type contact

           DO CHKFIN^ACDDEU

 +10       IF ACDQ

               SET ACDQ=0

               QUIT

 +11       SET DIC="^ACDPAT("_ACDCC_",1,"

 +12       SET DIC(0)="L"

 +13       SET DIC("P")=$PIECE(^DD(9002172.8,1,0),U,2)

 +14       SET DA=ACDDFNP

           SET DA(1)=ACDCC

 +15       SET DINUM=DA

 +16       SET X=ACDDFNP

 +17       DO FILE^ACDFMC

 +18       IF +Y<0

               WRITE !,"Creation of CLIENT entry failed.  Notify programmer.",!!

               SET ACDQ=1

               IF $DATA(^%ZOSF("$ZE"))

                   SET X="CDMIS CLIENT CATEGORY CLIENT"

                   SET @^("$ZE")

               DO @^%ZOSF("ERRTN")

               QUIT

 +19       SET ACDNEWP=1

 +20       DO EDIT

 +21       QUIT

 +22      ;

PATED     ; SELECT AN EXISTING PATIENT TO EDIT

 +1        WRITE !

 +2        SET DIC="^ACDPAT(ACDCC,1,"

           SET DIC(0)="AEMQ"

           DO ^DIC

 +3        IF Y<0

               SET ACDQ=1

               QUIT

 +4        SET ACDDFNP=+Y

 +5        SET ACDDFN=$PIECE(^DPT(ACDDFNP,0),U)

 +6        DO GETDEMO^ACDDEGP

 +7        DO EDIT

 +8        QUIT

 +9       ;

EDIT      ; EDIT AN EXISTING PATIENT

 +1        SET DIE="^ACDPAT("_ACDCC_",1,"

 +2        SET DA=ACDDFNP

           SET DA(1)=ACDCC

 +3        SET DR=""

 +4        IF '$GET(ACDNEWP)

               SET DR=".01//"_ACDDFN_";"

 +5        SET DR=DR_"2////"_ACDTRBCD_";3////"_ACDSEX_";4////"_ACDAGER_";22////"_ACDSTACD_";23////"_ACDSTA_";24////"_ACDTRB_";25////"_ACDVET_";26////"_ACDAGE

 +6        DO DIE^ACDFMC

 +7        WRITE !,"  Patient demographic information set from Patient Registration data."

 +8        QUIT

 +9       ;

EOJ       ;

 +1        KILL ACDNEWG

 +2        DO ^ACDKILL

 +3        QUIT

ACDCSD.m