ACDRR3C.m

ACDRR3C ;IHS/ADC/EDE/KML - PROCESS CDMIS VISITS;

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

 ; This routine processes each visit for one patient within date range

 ; and lists the stages over time.  Date range and patient ien passed

 ; by calling routine.

 ;

START ;

 D INIT

 D VISITS ;                     process visits for selected patient

 D EOJ

 Q

 ;

INIT ;

 S (ACDBT,ACDBTH)=$H,ACDJOB=$J

 K ^TMP("ACDRR3",$J)

 Q

 ;

VISITS ; PROCESS ALL VISITS FOR PATIENT WITHIN DATE RANGE

 S ACDVCNT=0

 S ACDVIEN=0

 F  S ACDVIEN=$O(^ACDVIS("D",ACDDFNP,ACDVIEN)) Q:'ACDVIEN  D VISIT

 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 ACDVDATE=$P(X,U) ;                   visit date

 Q:ACDVDATE<ACDDTLO!(ACDVDATE>ACDDTHI)  ; quit if not in range

 S ACDTC=$P(X,U,4) ;                    type contact

 I ACDTC'="IN",ACDTC'="RE",ACDTC'="TD",ACDTC'="FU" Q

 S ACDDFNP=$P(X,U,5) ;                  patient ien

 Q:'ACDDFNP  ;                          bad data

 I '$D(^TMP("ACDRR3",$J,ACDBTH,"PATIENT",ACDDFNP)) S ^(ACDDFNP)=""

 S ACDVCNT=ACDVCNT+1

 D @("PRC"_ACDTC) ;                     process iif/td

 Q

 ;

PRCIN ; INITIAL

 D PRCIIF

 Q

 ;

PRCRE ; REOPEN

 D PRCIIF

 Q

 ;

PRCFU ; FOLLOWUP

 D PRCIIF

 Q

 ;

PRCIIF ; PROCESS IIF ENTRY

 S ACDIIEN=$O(^ACDIIF("C",ACDVIEN,0))

 Q:'ACDIIEN  ;                               no iif entry

 S ^TMP("ACDRR3",$J,ACDBTH,"PATIENT",ACDDFNP)=1 ; patients has iif or td

 S ^TMP("ACDRR3",$J,ACDBTH,"V",ACDVDATE,ACDVCNT,"TC")=ACDTC

 F ACDFIELD=9,10,11,12,13,14,14.5 D

 .  S ACDCOL=$P($T(@("IIFC"_$TR(ACDFIELD,".","P"))),";;",2)

 .  S ^TMP("ACDRR3",$J,ACDBTH,"V",ACDVDATE,ACDVCNT,"COL",ACDCOL)=$$VAL^XBDIQ1(9002170,ACDIIEN,ACDFIELD)

 .  Q

 Q

 ;

IIFC9 ;;1

IIFC10 ;;2

IIFC11 ;;3

IIFC12 ;;4

IIFC13 ;;5

IIFC14 ;;6

IIFC14P5 ;;7

 ;

PRCTD ; TRANS/DISC/CLOSE ENTRY

 S ACDTIEN=$O(^ACDTDC("C",ACDVIEN,0))

 Q:'ACDTIEN  ;                          no tdc entry

 S ^TMP("ACDRR3",$J,ACDBTH,"PATIENT",ACDDFNP)=1 ; patients has iif or td

 S ^TMP("ACDRR3",$J,ACDBTH,"V",ACDVDATE,ACDVCNT,"TC")=ACDTC

 F ACDFIELD=6,7,8,9,10,11,11.5 D

 .  S ACDCOL=$P($T(@("TDCC"_$TR(ACDFIELD,".","P"))),";;",2)

 .  S ^TMP("ACDRR3",$J,ACDBTH,"V",ACDVDATE,ACDVCNT,"COL",ACDCOL)=$$VAL^XBDIQ1(9002171,ACDTIEN,ACDFIELD)

 .  Q

 Q

 ;

TDCC6 ;;1

TDCC7 ;;2

TDCC8 ;;3

TDCC9 ;;4

TDCC10 ;;5

TDCC11 ;;6

TDCC11P5 ;;7

 ;

EOJ ;

 S ACDET=$H

 K C,X,Y,Z

 K ACDDFNP,ACDVCNT,ACDVDATE,ACDVIEN

 ;K ^TMP("ACDRR3",$J,1)

 Q

ACDRR3C   ;IHS/ADC/EDE/KML - PROCESS CDMIS VISITS;

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

 +2       ; This routine processes each visit for one patient within date range

 +3       ; and lists the stages over time.  Date range and patient ien passed

 +4       ; by calling routine.

 +5       ;

START     ;

 +1        DO INIT

 +2       ;                     process visits for selected patient

           DO VISITS

 +3        DO EOJ

 +4        QUIT 

 +5       ;

INIT      ;

 +1        SET (ACDBT,ACDBTH)=$HOROLOG

           SET ACDJOB=$JOB

 +2        KILL ^TMP("ACDRR3",$JOB)

 +3        QUIT 

 +4       ;

VISITS    ; PROCESS ALL VISITS FOR PATIENT WITHIN DATE RANGE

 +1        SET ACDVCNT=0

 +2        SET ACDVIEN=0

 +3        FOR 

               SET ACDVIEN=$ORDER(^ACDVIS("D",ACDDFNP,ACDVIEN))

               IF 'ACDVIEN

                   QUIT 

               DO VISIT

 +4        QUIT 

 +5       ;

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       ;                   visit date

           SET ACDVDATE=$PIECE(X,U)

 +5       ; quit if not in range

           IF ACDVDATE<ACDDTLO!(ACDVDATE>ACDDTHI)

               QUIT 

 +6       ;                    type contact

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

 +7        IF ACDTC'="IN"

               IF ACDTC'="RE"

                   IF ACDTC'="TD"

                       IF ACDTC'="FU"

                           QUIT 

 +8       ;                  patient ien

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

 +9       ;                          bad data

           IF 'ACDDFNP

               QUIT 

 +10       IF '$DATA(^TMP("ACDRR3",$JOB,ACDBTH,"PATIENT",ACDDFNP))

               SET ^(ACDDFNP)=""

 +11       SET ACDVCNT=ACDVCNT+1

 +12      ;                     process iif/td

           DO @("PRC"_ACDTC)

 +13       QUIT 

 +14      ;

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    ; PROCESS IIF ENTRY

 +1        SET ACDIIEN=$ORDER(^ACDIIF("C",ACDVIEN,0))

 +2       ;                               no iif entry

           IF 'ACDIIEN

               QUIT 

 +3       ; patients has iif or td

           SET ^TMP("ACDRR3",$JOB,ACDBTH,"PATIENT",ACDDFNP)=1

 +4        SET ^TMP("ACDRR3",$JOB,ACDBTH,"V",ACDVDATE,ACDVCNT,"TC")=ACDTC

 +5        FOR ACDFIELD=9,10,11,12,13,14,14.5

               Begin DoDot:1

 +6                SET ACDCOL=$PIECE($TEXT(@("IIFC"_$TRANSLATE(ACDFIELD,".","P"))),";;",2)

 +7                SET ^TMP("ACDRR3",$JOB,ACDBTH,"V",ACDVDATE,ACDVCNT,"COL",ACDCOL)=$$VAL^XBDIQ1(9002170,ACDIIEN,ACDFIELD)

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

 +10      ;

IIFC9     ;;1

IIFC10    ;;2

IIFC11    ;;3

IIFC12    ;;4

IIFC13    ;;5

IIFC14    ;;6

IIFC14P5  ;;7

 +1       ;

PRCTD     ; TRANS/DISC/CLOSE ENTRY

 +1        SET ACDTIEN=$ORDER(^ACDTDC("C",ACDVIEN,0))

 +2       ;                          no tdc entry

           IF 'ACDTIEN

               QUIT 

 +3       ; patients has iif or td

           SET ^TMP("ACDRR3",$JOB,ACDBTH,"PATIENT",ACDDFNP)=1

 +4        SET ^TMP("ACDRR3",$JOB,ACDBTH,"V",ACDVDATE,ACDVCNT,"TC")=ACDTC

 +5        FOR ACDFIELD=6,7,8,9,10,11,11.5

               Begin DoDot:1

 +6                SET ACDCOL=$PIECE($TEXT(@("TDCC"_$TRANSLATE(ACDFIELD,".","P"))),";;",2)

 +7                SET ^TMP("ACDRR3",$JOB,ACDBTH,"V",ACDVDATE,ACDVCNT,"COL",ACDCOL)=$$VAL^XBDIQ1(9002171,ACDTIEN,ACDFIELD)

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

 +10      ;

TDCC6     ;;1

TDCC7     ;;2

TDCC8     ;;3

TDCC9     ;;4

TDCC10    ;;5

TDCC11    ;;6

TDCC11P5  ;;7

 +1       ;

EOJ       ;

 +1        SET ACDET=$HOROLOG

 +2        KILL C,X,Y,Z

 +3        KILL ACDDFNP,ACDVCNT,ACDVDATE,ACDVIEN

 +4       ;K ^TMP("ACDRR3",$J,1)

 +5        QUIT