- 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
