ACDCSD ;IHS/ADC/EDE/KML - DATA ENTER/EDIT FOR CLIENT CATEGORIES;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
START ;
D MAIN
D EOJ
Q
;
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
Q
;
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
Q
;
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
Q
;
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,",!
Q
;
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
Q
;
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
Q
;
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."
Q
;
EOJ ;
K ACDNEWG
D ^ACDKILL
Q
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
