ACDRR1C ;IHS/ADC/EDE/KML - PROCESS CDMIS VISITS;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; This routine processes each visit within date range, determines
; if patient has problem of alcohol or drugs, and counts substances
; being used. A count is also kept for each problem encountered.
;
START ;
D INIT
D VISITS
D PATIENTS
D EOJ
Q
;
INIT ;
S (ACDBT,ACDBTH)=$H,ACDJOB=$J
K ^TMP("ACDRR1",$J)
Q
;
VISITS ; PROCESS ALL VISITS WITHIN DATE RANGE
S ACDVCNT=0
S ACDVDATE=$O(^ACDVIS("B",ACDDTLO),-1)
F S ACDVDATE=$O(^ACDVIS("B",ACDVDATE)) Q:ACDVDATE=""!(ACDVDATE>ACDDTHI) D
. S ACDVIEN=0
. F S ACDVIEN=$O(^ACDVIS("B",ACDVDATE,ACDVIEN)) Q:'ACDVIEN D VISIT
. Q
Q
;
VISIT ; PROCESS ONE VISIT
Q:'$D(^ACDVIS(ACDVIEN,0)) ; bad xref
Q:$G(^ACDVIS(ACDVIEN,"BWP"))'=ACDPGM ;not from current program
S X=^ACDVIS(ACDVIEN,0)
S ACDTC=$P(X,U,4) ; type contact
I ACDTC="IR"!(ACDTC="OT") Q
S ACDPIEN=$P(X,U,5) ; patient ien
Q:'ACDPIEN ; bad data
I '$D(^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN)) S ^(ACDPIEN)=""
I ACDTC="CS" S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"CS",ACDVIEN)="" Q
I ACDTC="TD" D
. NEW ACDCODE,ACDTYPE,ACDDATE
. S ACDDATE=$P(X,U),ACDCODE=$P(X,U,2),ACDTYPE=$P(X,U,7)
. S ^TMP("ACDRR1",$J,1,"LOS",ACDPIEN,ACDCODE_"/"_ACDTYPE,ACDDATE)=ACDVIEN
. Q
D @("PRC"_ACDTC) ; process iif/td
S ACDVCNT=ACDVCNT+1
S (X,Y)=""
I $D(^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"A",ACDVIEN)) S X="A"
F S Y=$O(ACDSTBL(Y)) Q:Y="" S ^TMP("ACDRR1",$J,1,"DRUG",Y,ACDPIEN)="",X=$S(X="":Y,1:X_","_Y)
I X'="",X["," S ^TMP("ACDRR1",$J,1,"DRUG COMBO",X,ACDPIEN)=""
Q
;
PRCIN ; INITIAL
D PRCIIF
Q
;
PRCRE ; REOPEN
D PRCIIF
Q
;
PRCFU ; FOLLOWUP
D PRCIIF
Q
;
PRCIIF ; EP-PROCESS IIF ENTRY
K ACDSTBL
S ACDIIEN=$O(^ACDIIF("C",ACDVIEN,0))
Q:'ACDIIEN ; no iif entry
S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN)=1 ; patients has iif or td
D PRCIIF2 ; check problems
D PRCIIF3 ; check drugs
Q
;
PRCIIF2 ; CHECK FOR PROBLEM OF ALCOHOL OR DRUGS & SAVE ALL PROBLEMS
; do not stop when both found because need visits
Q:'$D(^ACDIIF(ACDIIEN,0)) ; bad xref
S X=^ACDIIF(ACDIIEN,0)
S ACDTOB=$P(X,U,30) ; save tobacco use
D:ACDTOB PRCSETT
S ACDADAYS=$P(X,U,4) ; save days used alcohol
S ACDDDAYS=$P(X,U,5) ; save days used drugs
S X=+X
S ^TMP("ACDRR1",$J,1,"PROBLEM",X,ACDPIEN)=""
S ^TMP("ACDRR1",$J,1,"PRI PROB",X,ACDPIEN)=""
I X=ACDAIEN D PRCSETA
I X=ACDDIEN D PRCSETD
S Y=0
F S Y=$O(^ACDIIF(ACDIIEN,3,Y)) Q:'Y I $D(^ACDIIF(ACDIIEN,3,Y,0)) S X=+^(0) D
. S ^TMP("ACDRR1",$J,1,"PROBLEM",X,ACDPIEN)=""
. I X=ACDAIEN D PRCSETA
. I X=ACDDIEN D PRCSETD
. Q
Q
;
PRCIIF3 ; CHECK FOR DRUGS
Q:'$D(^ACDIIF(ACDIIEN,0)) ; bad xref
S Y=0
F S Y=$O(^ACDIIF(ACDIIEN,2,Y)) Q:'Y I $D(^ACDIIF(ACDIIEN,2,Y,0)) S X=+^(0) S ACDSTBL(X)=""
Q
;
PRCTD ; EP-TRANS/DISC/CLOSE ENTRY
K ACDSTBL
S ACDTIEN=$O(^ACDTDC("C",ACDVIEN,0))
Q:'ACDTIEN ; no tdc entry
S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN)=1 ; patients has iif or td
D PRCTD2 ; check alcohol
D PRCTD3 ; check drugs
Q
;
PRCTD2 ; CHECK FOR PROBLEM OF ALCOHOL OR DRUGS & SAVE ALL PROBLEMS
; do not stop when both found because need visits
Q:'$D(^ACDTDC(ACDTIEN,0)) ; bad xref
S X=^ACDTDC(ACDTIEN,0)
S ACDTOB=$P(X,U,30) ; save tobacco use
D:ACDTOB PRCSETT
S ACDADAYS=$P(X,U) ; save days used alcohol
S ACDDDAYS=$P(X,U,2) ; save days used drugs
S X=$P(X,U,27)
Q:'X ; bad data
S ^TMP("ACDRR1",$J,1,"PROBLEM",X,ACDPIEN)=""
S ^TMP("ACDRR1",$J,1,"PRI PROB",X,ACDPIEN)=""
I X=ACDAIEN S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"A")="",^("A",ACDVIEN)=""
I X=ACDDIEN S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"D")="",^("D",ACDVIEN)=""
S Y=0
F S Y=$O(^ACDTDC(ACDTIEN,3,Y)) Q:'Y I $D(^ACDTDC(ACDTIEN,3,Y,0)) S X=+^(0) D
. S ^TMP("ACDRR1",$J,1,"PROBLEM",X,ACDPIEN)=""
. I X=ACDAIEN S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"A")="",^("A",ACDVIEN)=""
. I X=ACDDIEN S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"D")="",^("D",ACDVIEN)=""
. Q
Q
;
PRCTD3 ; CHECK FOR DRUGS
Q:'$D(^ACDTDC(ACDTIEN,0)) ; bad xref
S Y=0
F S Y=$O(^ACDTDC(ACDTIEN,2,Y)) Q:'Y I $D(^ACDTDC(ACDTIEN,2,Y,0)) S X=+^(0) S ACDSTBL(X)=""
Q
;
PRCSETA ; SET ALCOHOL HIT
S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"A")="",^("A",ACDVIEN)="",^(ACDVIEN,"DAYS")=ACDADAYS
Q
;
PRCSETD ; SET DRUG HIT
S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"D")="",^("D",ACDVIEN)="",^(ACDVIEN,"DAYS")=ACDDDAYS
Q
;
PRCSETT ; SET TOBACCO HIT
S ^TMP("ACDRR1",$J,1,"PATIENT",ACDPIEN,"T",ACDTOB)=""
Q
;
PATIENTS ; PROCESS PATIENTS WITH VISITS WITHIN TIME FRAME
D PATIENTS^ACDRR1CB
Q
;
EOJ ;
S ACDET=$H
K C,X,Y,Z
K ACDA,ACDADAYS,ACDAGE,ACDAIEN,ACDCMBO,ACDCSC,ACDCSH,ACDCSHC,ACDCSIEN,ACDCT,ACDD,ACDDDAYS,ACDDIEN,ACDDRUG,ACDIIEN,ACDPIEN,ACDPRIEN,ACDSEX,ACDSTBL,ACDTC,ACDTOB,ACDTIEN,ACDVCNT,ACDVDATE,ACDVIEN
K ^TMP("ACDRR1",$J,1)
Q
ACDRR1C ;IHS/ADC/EDE/KML - PROCESS CDMIS VISITS;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ; This routine processes each visit within date range, determines
+4 ; if patient has problem of alcohol or drugs, and counts substances
+5 ; being used. A count is also kept for each problem encountered.
+6 ;
START ;
+1 DO INIT
+2 DO VISITS
+3 DO PATIENTS
+4 DO EOJ
+5 QUIT
+6 ;
INIT ;
+1 SET (ACDBT,ACDBTH)=$HOROLOG
SET ACDJOB=$JOB
+2 KILL ^TMP("ACDRR1",$JOB)
+3 QUIT
+4 ;
VISITS ; PROCESS ALL VISITS WITHIN DATE RANGE
+1 SET ACDVCNT=0
+2 SET ACDVDATE=$ORDER(^ACDVIS("B",ACDDTLO),-1)
+3 FOR
SET ACDVDATE=$ORDER(^ACDVIS("B",ACDVDATE))
IF ACDVDATE=""!(ACDVDATE>ACDDTHI)
QUIT
Begin DoDot:1
+4 SET ACDVIEN=0
+5 FOR
SET ACDVIEN=$ORDER(^ACDVIS("B",ACDVDATE,ACDVIEN))
IF 'ACDVIEN
QUIT
DO VISIT
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
VISIT ; PROCESS ONE VISIT
+1 ; bad xref
IF '$DATA(^ACDVIS(ACDVIEN,0))
QUIT
+2 ;not from current program
IF $GET(^ACDVIS(ACDVIEN,"BWP"))'=ACDPGM
QUIT
+3 SET X=^ACDVIS(ACDVIEN,0)
+4 ; type contact
SET ACDTC=$PIECE(X,U,4)
+5 IF ACDTC="IR"!(ACDTC="OT")
QUIT
+6 ; patient ien
SET ACDPIEN=$PIECE(X,U,5)
+7 ; bad data
IF 'ACDPIEN
QUIT
+8 IF '$DATA(^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN))
SET ^(ACDPIEN)=""
+9 IF ACDTC="CS"
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"CS",ACDVIEN)=""
QUIT
+10 IF ACDTC="TD"
Begin DoDot:1
+11 NEW ACDCODE,ACDTYPE,ACDDATE
+12 SET ACDDATE=$PIECE(X,U)
SET ACDCODE=$PIECE(X,U,2)
SET ACDTYPE=$PIECE(X,U,7)
+13 SET ^TMP("ACDRR1",$JOB,1,"LOS",ACDPIEN,ACDCODE_"/"_ACDTYPE,ACDDATE)=ACDVIEN
+14 QUIT
End DoDot:1
+15 ; process iif/td
DO @("PRC"_ACDTC)
+16 SET ACDVCNT=ACDVCNT+1
+17 SET (X,Y)=""
+18 IF $DATA(^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"A",ACDVIEN))
SET X="A"
+19 FOR
SET Y=$ORDER(ACDSTBL(Y))
IF Y=""
QUIT
SET ^TMP("ACDRR1",$JOB,1,"DRUG",Y,ACDPIEN)=""
SET X=$SELECT(X="":Y,1:X_","_Y)
+20 IF X'=""
IF X[","
SET ^TMP("ACDRR1",$JOB,1,"DRUG COMBO",X,ACDPIEN)=""
+21 QUIT
+22 ;
PRCIN ; INITIAL
+1 DO PRCIIF
+2 QUIT
+3 ;
PRCRE ; REOPEN
+1 DO PRCIIF
+2 QUIT
+3 ;
PRCFU ; FOLLOWUP
+1 DO PRCIIF
+2 QUIT
+3 ;
PRCIIF ; EP-PROCESS IIF ENTRY
+1 KILL ACDSTBL
+2 SET ACDIIEN=$ORDER(^ACDIIF("C",ACDVIEN,0))
+3 ; no iif entry
IF 'ACDIIEN
QUIT
+4 ; patients has iif or td
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN)=1
+5 ; check problems
DO PRCIIF2
+6 ; check drugs
DO PRCIIF3
+7 QUIT
+8 ;
PRCIIF2 ; CHECK FOR PROBLEM OF ALCOHOL OR DRUGS & SAVE ALL PROBLEMS
+1 ; do not stop when both found because need visits
+2 ; bad xref
IF '$DATA(^ACDIIF(ACDIIEN,0))
QUIT
+3 SET X=^ACDIIF(ACDIIEN,0)
+4 ; save tobacco use
SET ACDTOB=$PIECE(X,U,30)
+5 IF ACDTOB
DO PRCSETT
+6 ; save days used alcohol
SET ACDADAYS=$PIECE(X,U,4)
+7 ; save days used drugs
SET ACDDDAYS=$PIECE(X,U,5)
+8 SET X=+X
+9 SET ^TMP("ACDRR1",$JOB,1,"PROBLEM",X,ACDPIEN)=""
+10 SET ^TMP("ACDRR1",$JOB,1,"PRI PROB",X,ACDPIEN)=""
+11 IF X=ACDAIEN
DO PRCSETA
+12 IF X=ACDDIEN
DO PRCSETD
+13 SET Y=0
+14 FOR
SET Y=$ORDER(^ACDIIF(ACDIIEN,3,Y))
IF 'Y
QUIT
IF $DATA(^ACDIIF(ACDIIEN,3,Y,0))
SET X=+^(0)
Begin DoDot:1
+15 SET ^TMP("ACDRR1",$JOB,1,"PROBLEM",X,ACDPIEN)=""
+16 IF X=ACDAIEN
DO PRCSETA
+17 IF X=ACDDIEN
DO PRCSETD
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
PRCIIF3 ; CHECK FOR DRUGS
+1 ; bad xref
IF '$DATA(^ACDIIF(ACDIIEN,0))
QUIT
+2 SET Y=0
+3 FOR
SET Y=$ORDER(^ACDIIF(ACDIIEN,2,Y))
IF 'Y
QUIT
IF $DATA(^ACDIIF(ACDIIEN,2,Y,0))
SET X=+^(0)
SET ACDSTBL(X)=""
+4 QUIT
+5 ;
PRCTD ; EP-TRANS/DISC/CLOSE ENTRY
+1 KILL ACDSTBL
+2 SET ACDTIEN=$ORDER(^ACDTDC("C",ACDVIEN,0))
+3 ; no tdc entry
IF 'ACDTIEN
QUIT
+4 ; patients has iif or td
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN)=1
+5 ; check alcohol
DO PRCTD2
+6 ; check drugs
DO PRCTD3
+7 QUIT
+8 ;
PRCTD2 ; CHECK FOR PROBLEM OF ALCOHOL OR DRUGS & SAVE ALL PROBLEMS
+1 ; do not stop when both found because need visits
+2 ; bad xref
IF '$DATA(^ACDTDC(ACDTIEN,0))
QUIT
+3 SET X=^ACDTDC(ACDTIEN,0)
+4 ; save tobacco use
SET ACDTOB=$PIECE(X,U,30)
+5 IF ACDTOB
DO PRCSETT
+6 ; save days used alcohol
SET ACDADAYS=$PIECE(X,U)
+7 ; save days used drugs
SET ACDDDAYS=$PIECE(X,U,2)
+8 SET X=$PIECE(X,U,27)
+9 ; bad data
IF 'X
QUIT
+10 SET ^TMP("ACDRR1",$JOB,1,"PROBLEM",X,ACDPIEN)=""
+11 SET ^TMP("ACDRR1",$JOB,1,"PRI PROB",X,ACDPIEN)=""
+12 IF X=ACDAIEN
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"A")=""
SET ^("A",ACDVIEN)=""
+13 IF X=ACDDIEN
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"D")=""
SET ^("D",ACDVIEN)=""
+14 SET Y=0
+15 FOR
SET Y=$ORDER(^ACDTDC(ACDTIEN,3,Y))
IF 'Y
QUIT
IF $DATA(^ACDTDC(ACDTIEN,3,Y,0))
SET X=+^(0)
Begin DoDot:1
+16 SET ^TMP("ACDRR1",$JOB,1,"PROBLEM",X,ACDPIEN)=""
+17 IF X=ACDAIEN
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"A")=""
SET ^("A",ACDVIEN)=""
+18 IF X=ACDDIEN
SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"D")=""
SET ^("D",ACDVIEN)=""
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
PRCTD3 ; CHECK FOR DRUGS
+1 ; bad xref
IF '$DATA(^ACDTDC(ACDTIEN,0))
QUIT
+2 SET Y=0
+3 FOR
SET Y=$ORDER(^ACDTDC(ACDTIEN,2,Y))
IF 'Y
QUIT
IF $DATA(^ACDTDC(ACDTIEN,2,Y,0))
SET X=+^(0)
SET ACDSTBL(X)=""
+4 QUIT
+5 ;
PRCSETA ; SET ALCOHOL HIT
+1 SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"A")=""
SET ^("A",ACDVIEN)=""
SET ^(ACDVIEN,"DAYS")=ACDADAYS
+2 QUIT
+3 ;
PRCSETD ; SET DRUG HIT
+1 SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"D")=""
SET ^("D",ACDVIEN)=""
SET ^(ACDVIEN,"DAYS")=ACDDDAYS
+2 QUIT
+3 ;
PRCSETT ; SET TOBACCO HIT
+1 SET ^TMP("ACDRR1",$JOB,1,"PATIENT",ACDPIEN,"T",ACDTOB)=""
+2 QUIT
+3 ;
PATIENTS ; PROCESS PATIENTS WITH VISITS WITHIN TIME FRAME
+1 DO PATIENTS^ACDRR1CB
+2 QUIT
+3 ;
EOJ ;
+1 SET ACDET=$HOROLOG
+2 KILL C,X,Y,Z
+3 KILL ACDA,ACDADAYS,ACDAGE,ACDAIEN,ACDCMBO,ACDCSC,ACDCSH,ACDCSHC,ACDCSIEN,ACDCT,ACDD,ACDDDAYS,ACDDIEN,ACDDRUG,ACDIIEN,ACDPIEN,ACDPRIEN,ACDSEX,ACDSTBL,ACDTC,ACDTOB,ACDTIEN,ACDVCNT,ACDVDATE,ACDVIEN
+4 KILL ^TMP("ACDRR1",$JOB,1)
+5 QUIT
