ACDDEGP ;IHS/ADC/EDE/KML - GET PATIENT;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
GETPAT ; EP - GET CLIENT/PATIENT
S ACDQ=1
S AUPNLK("ALL")=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D DIC^ACDFMC
K AUPNLK("ALL")
Q:Y<0
S ACDDFNP=+Y,ACDDFN=$P(^DPT(ACDDFNP,0),U)
I $D(^TMP("ACD",$J,"PAT",ACDDFNP,"ACDDFNP")) D SETDEMO I 1
E D GETDEMO
Q:ACDQ ; ACDQ set to 0 by SETDEMO or GETDEMO if all ok
I ACDAGE,ACDAGER Q
W !!,IORVON,"No AGE and/or AGE RANGE for selected patient. Cannot continue.",IORVOFF,!!
D PAUSE^ACDDEU
S ACDQ=1
Q
;
SETDEMO ; EP - SET CLIENT/PATIENT DEMO VARIABLES
I $D(^TMP("ACD",$J,"PAT",ACDDFNP,"FLG","AGE CHG")) D GETREG
S X=""
F S X=$O(^TMP("ACD",$J,"PAT",ACDDFNP,X)) Q:X="" S:X'="FLG" @X=^(X)
I ACDAGE D ^ACDAGRG ; set age and age range as of visit date
I $D(^TMP("ACD",$J,"PAT",ACDDFNP,"FLG","AGE CHG")) W !!,"You previously changed this patient's age so you must edit the",!,"demographic data each time this patient is selected." D DSPDEMO I 1
E W !
S ACDQ=0
Q
;
GETDEMO ; EP - GET CLIENT/PATIENT DEMOGRAPHIC INFO
D GETREG ; get patient registration info
;D GETCDMIS ; get last cdmis info for same patient
;D DSPDEMO ; display and allow change of demographic info
;Q:ACDQ
D SVDEMO ; save demographic info
S ACDQ=0
Q
;
GETREG ; GET PATIENT REGISTRATION INFO
D GETREG^ACDDEGP2
Q
;
GETCDMIS ; GET LAST CDMIS INFO FOR PATIENT
D GETCDMIS^ACDDEGP2
Q
;
DSPDEMO ; DISPLAY AND ALLOW CHANGE OF DEMOGRAPHIC INFO
S $P(ACDDL,"-",79)=""
S ACDLC=0
F D DSPPAT Q:ACDQ
W !
D DSPDIFF
S ACDQ=0
Q
;
DSPPAT ; DISPLAY CLIENT/PATIENT DATA
W !!
W "PATIENT NAME: ",ACDDFN,!
I 'ACDLC D DSPDIFF
S ACDLC=ACDLC+1
W ACDDL,!
W "1. SEX: ",ACDSEX,!
I ACDPRD("ACDSEX")'=ACDSEX W ?32,@ACDRVON,ACDPRD("ACDSEX"),@ACDRVOF,!
W "2. AGE: ",ACDAGE,!
I ACDPRD("ACDAGE")'=ACDAGE W ?32,@ACDRVON,ACDPRD("ACDAGE"),@ACDRVOF,!
W " AGE RANGE: ",ACDAGER," (",$P($T(ART+ACDAGER),";;",2),")",!
W "3. IS CLIENT A VETERAN (Y/N): ",ACDVET,!
I ACDPRD("ACDVET")'=ACDVET W ?32,@ACDRVON,ACDPRD("ACDVET"),@ACDRVOF,!
W "4. RESIDENT STATE: ",ACDSTANM,!
I ACDPRD("ACDSTANM")'=ACDSTANM W ?32,@ACDRVON,ACDPRD("ACDSTANM"),@ACDRVOF,!
W "5. TRIBE: ",ACDTRBN,!
I ACDPRD("ACDTRBN")'=ACDTRBN W ?32,@ACDRVON,ACDPRD("ACDTRBN"),@ACDRVOF,!
W ACDDL,!
S ACDQ=1
S DIR(0)="NO^1:5:0",DIR("A")="Change which item? " K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDQ=0
W !
D @("CHG"_X)
Q
;
DSPDIFF ; DISPLAY DIFFERENCES IN DEMO DATA VALUES
S ACDY=0 F X="ACDSEX","ACDAGE","ACDVET","ACDSTANM","ACDTRBN" D
. S Y=$S(X="ACDSEX":1,X="ACDAGE":2,X="ACDVET":3,X="ACDSTANM":4,1:5)
. I @X'=ACDPRD(X) D
.. W:'ACDY !,?4,@ACDRVON,"PATIENT REGISTRATION DATA DIFFERS FOR THE FOLLOWING ITEMS:",@ACDRVOF,!
.. S ACDY=1
.. W ?8,@ACDRVON,Y,". ",$S(Y=1:"SEX",Y=2:"AGE",Y=3:"IS CLIENT A VET (Y/N)",Y=4:"RESIDENT STATE",1:"TRIBE"),": ",ACDPRD(X),@ACDRVOF,!
.. Q
. Q
Q
;
CHG1 ; CHANGE SEX
S DIR(0)="9002172.1,103",DIR("B")=$S($E(ACDSEX)="M":"FEMALE",1:"MALE") K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDSEX=Y(0)
Q
;
CHG2 ; CHANGE AGE
S DIR(0)="9002172.1,107" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDAGE=Y
D SETRG^ACDAGRG ; get age range
S ^TMP("ACD",$J,"PAT",ACDDFNP,"FLG","AGE CHG")=1
Q
;
CHG3 ; CHANGE VETERAN STATUS
S DIR(0)="9002172.1,104" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDVET=Y(0)
Q
;
CHG4 ; CHANGE STATE
S DIR(0)="P^5:EMZ" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDSTA=Y
S ACDSTACD=$P(Y(0),U,3)
S ACDSTANM=$P(Y(0),U)
Q
;
CHG5 ; CHANGE TRIBE
S DIR(0)="P^9999999.03:EMZ" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDTRB=Y
S ACDTRBCD=$P(Y(0),U,2)
S ACDTRBN=$P(Y(0),U)
Q
;
SVDEMO ; SAVE DEMOGRAPHIC INFO
;---------- save demographic info
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDAGER")=ACDAGER
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDAGE")=ACDAGE
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDCOMM")=ACDCOMM
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDDFN")=ACDDFN
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDDFNP")=ACDDFNP
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDSEX")=ACDSEX
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDSTA")=ACDSTA
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDSTACD")=ACDSTACD
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDSTANM")=ACDSTANM
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDTRB")=ACDTRB
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDTRBCD")=ACDTRBCD
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDTRBN")=ACDTRBN
S ^TMP("ACD",$J,"PAT",ACDDFNP,"ACDVET")=ACDVET
S ^TMP("ACD",$J,"PAT",ACDDFNP,"AUPNDAYS")=AUPNDAYS
S ^TMP("ACD",$J,"PAT",ACDDFNP,"AUPNDOB")=AUPNDOB
S ^TMP("ACD",$J,"PAT",ACDDFNP,"AUPNDOD")=AUPNDOD
S ^TMP("ACD",$J,"PAT",ACDDFNP,"AUPNPAT")=AUPNPAT
S ^TMP("ACD",$J,"PAT",ACDDFNP,"AUPNSEX")=AUPNSEX
Q
;
ART ; AGE RANGE TABLE
;;0-12
;;13-18
;;19-24
;;25-34
;;35-44
;;45-54
;;55-64
;;65-74
;;75+
ACDDEGP ;IHS/ADC/EDE/KML - GET PATIENT;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
GETPAT ; EP - GET CLIENT/PATIENT
+1 SET ACDQ=1
+2 SET AUPNLK("ALL")=1
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO DIC^ACDFMC
+4 KILL AUPNLK("ALL")
+5 IF Y<0
QUIT
+6 SET ACDDFNP=+Y
SET ACDDFN=$PIECE(^DPT(ACDDFNP,0),U)
+7 IF $DATA(^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDDFNP"))
DO SETDEMO
IF 1
+8 IF '$TEST
DO GETDEMO
+9 ; ACDQ set to 0 by SETDEMO or GETDEMO if all ok
IF ACDQ
QUIT
+10 IF ACDAGE
IF ACDAGER
QUIT
+11 WRITE !!,IORVON,"No AGE and/or AGE RANGE for selected patient. Cannot continue.",IORVOFF,!!
+12 DO PAUSE^ACDDEU
+13 SET ACDQ=1
+14 QUIT
+15 ;
SETDEMO ; EP - SET CLIENT/PATIENT DEMO VARIABLES
+1 IF $DATA(^TMP("ACD",$JOB,"PAT",ACDDFNP,"FLG","AGE CHG"))
DO GETREG
+2 SET X=""
+3 FOR
SET X=$ORDER(^TMP("ACD",$JOB,"PAT",ACDDFNP,X))
IF X=""
QUIT
IF X'="FLG"
SET @X=^(X)
+4 ; set age and age range as of visit date
IF ACDAGE
DO ^ACDAGRG
+5 IF $DATA(^TMP("ACD",$JOB,"PAT",ACDDFNP,"FLG","AGE CHG"))
WRITE !!,"You previously changed this patient's age so you must edit the",!,"demographic data each time this patient is selected."
DO DSPDEMO
IF 1
+6 IF '$TEST
WRITE !
+7 SET ACDQ=0
+8 QUIT
+9 ;
GETDEMO ; EP - GET CLIENT/PATIENT DEMOGRAPHIC INFO
+1 ; get patient registration info
DO GETREG
+2 ;D GETCDMIS ; get last cdmis info for same patient
+3 ;D DSPDEMO ; display and allow change of demographic info
+4 ;Q:ACDQ
+5 ; save demographic info
DO SVDEMO
+6 SET ACDQ=0
+7 QUIT
+8 ;
GETREG ; GET PATIENT REGISTRATION INFO
+1 DO GETREG^ACDDEGP2
+2 QUIT
+3 ;
GETCDMIS ; GET LAST CDMIS INFO FOR PATIENT
+1 DO GETCDMIS^ACDDEGP2
+2 QUIT
+3 ;
DSPDEMO ; DISPLAY AND ALLOW CHANGE OF DEMOGRAPHIC INFO
+1 SET $PIECE(ACDDL,"-",79)=""
+2 SET ACDLC=0
+3 FOR
DO DSPPAT
IF ACDQ
QUIT
+4 WRITE !
+5 DO DSPDIFF
+6 SET ACDQ=0
+7 QUIT
+8 ;
DSPPAT ; DISPLAY CLIENT/PATIENT DATA
+1 WRITE !!
+2 WRITE "PATIENT NAME: ",ACDDFN,!
+3 IF 'ACDLC
DO DSPDIFF
+4 SET ACDLC=ACDLC+1
+5 WRITE ACDDL,!
+6 WRITE "1. SEX: ",ACDSEX,!
+7 IF ACDPRD("ACDSEX")'=ACDSEX
WRITE ?32,@ACDRVON,ACDPRD("ACDSEX"),@ACDRVOF,!
+8 WRITE "2. AGE: ",ACDAGE,!
+9 IF ACDPRD("ACDAGE")'=ACDAGE
WRITE ?32,@ACDRVON,ACDPRD("ACDAGE"),@ACDRVOF,!
+10 WRITE " AGE RANGE: ",ACDAGER," (",$PIECE($TEXT(ART+ACDAGER),";;",2),")",!
+11 WRITE "3. IS CLIENT A VETERAN (Y/N): ",ACDVET,!
+12 IF ACDPRD("ACDVET")'=ACDVET
WRITE ?32,@ACDRVON,ACDPRD("ACDVET"),@ACDRVOF,!
+13 WRITE "4. RESIDENT STATE: ",ACDSTANM,!
+14 IF ACDPRD("ACDSTANM")'=ACDSTANM
WRITE ?32,@ACDRVON,ACDPRD("ACDSTANM"),@ACDRVOF,!
+15 WRITE "5. TRIBE: ",ACDTRBN,!
+16 IF ACDPRD("ACDTRBN")'=ACDTRBN
WRITE ?32,@ACDRVON,ACDPRD("ACDTRBN"),@ACDRVOF,!
+17 WRITE ACDDL,!
+18 SET ACDQ=1
+19 SET DIR(0)="NO^1:5:0"
SET DIR("A")="Change which item? "
KILL DA
DO ^DIR
KILL DIR
+20 IF $DATA(DIRUT)
QUIT
+21 SET ACDQ=0
+22 WRITE !
+23 DO @("CHG"_X)
+24 QUIT
+25 ;
DSPDIFF ; DISPLAY DIFFERENCES IN DEMO DATA VALUES
+1 SET ACDY=0
FOR X="ACDSEX","ACDAGE","ACDVET","ACDSTANM","ACDTRBN"
Begin DoDot:1
+2 SET Y=$SELECT(X="ACDSEX":1,X="ACDAGE":2,X="ACDVET":3,X="ACDSTANM":4,1:5)
+3 IF @X'=ACDPRD(X)
Begin DoDot:2
+4 IF 'ACDY
WRITE !,?4,@ACDRVON,"PATIENT REGISTRATION DATA DIFFERS FOR THE FOLLOWING ITEMS:",@ACDRVOF,!
+5 SET ACDY=1
+6 WRITE ?8,@ACDRVON,Y,". ",$SELECT(Y=1:"SEX",Y=2:"AGE",Y=3:"IS CLIENT A VET (Y/N)",Y=4:"RESIDENT STATE",1:"TRIBE"),": ",ACDPRD(X),@ACDRVOF,!
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
CHG1 ; CHANGE SEX
+1 SET DIR(0)="9002172.1,103"
SET DIR("B")=$SELECT($EXTRACT(ACDSEX)="M":"FEMALE",1:"MALE")
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 SET ACDSEX=Y(0)
+4 QUIT
+5 ;
CHG2 ; CHANGE AGE
+1 SET DIR(0)="9002172.1,107"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 SET ACDAGE=Y
+4 ; get age range
DO SETRG^ACDAGRG
+5 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"FLG","AGE CHG")=1
+6 QUIT
+7 ;
CHG3 ; CHANGE VETERAN STATUS
+1 SET DIR(0)="9002172.1,104"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 SET ACDVET=Y(0)
+4 QUIT
+5 ;
CHG4 ; CHANGE STATE
+1 SET DIR(0)="P^5:EMZ"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 SET ACDSTA=Y
+4 SET ACDSTACD=$PIECE(Y(0),U,3)
+5 SET ACDSTANM=$PIECE(Y(0),U)
+6 QUIT
+7 ;
CHG5 ; CHANGE TRIBE
+1 SET DIR(0)="P^9999999.03:EMZ"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 SET ACDTRB=Y
+4 SET ACDTRBCD=$PIECE(Y(0),U,2)
+5 SET ACDTRBN=$PIECE(Y(0),U)
+6 QUIT
+7 ;
SVDEMO ; SAVE DEMOGRAPHIC INFO
+1 ;---------- save demographic info
+2 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDAGER")=ACDAGER
+3 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDAGE")=ACDAGE
+4 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDCOMM")=ACDCOMM
+5 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDDFN")=ACDDFN
+6 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDDFNP")=ACDDFNP
+7 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDSEX")=ACDSEX
+8 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDSTA")=ACDSTA
+9 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDSTACD")=ACDSTACD
+10 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDSTANM")=ACDSTANM
+11 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDTRB")=ACDTRB
+12 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDTRBCD")=ACDTRBCD
+13 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDTRBN")=ACDTRBN
+14 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"ACDVET")=ACDVET
+15 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"AUPNDAYS")=AUPNDAYS
+16 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"AUPNDOB")=AUPNDOB
+17 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"AUPNDOD")=AUPNDOD
+18 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"AUPNPAT")=AUPNPAT
+19 SET ^TMP("ACD",$JOB,"PAT",ACDDFNP,"AUPNSEX")=AUPNSEX
+20 QUIT
+21 ;
ART ; AGE RANGE TABLE
+1 ;;0-12
+2 ;;13-18
+3 ;;19-24
+4 ;;25-34
+5 ;;35-44
+6 ;;45-54
+7 ;;55-64
+8 ;;65-74
+9 ;;75+
