ACDRL1.m

ACDRL1 ;IHS/ADC/EDE/KML - PROCESS RECORD LIST;

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

 ;

 ;

 ;

START ;

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

 I $D(ACDRDTR),ACDPTVS="P" S X1=ACDBD,X2=-1 D C^%DTC S ACDSD=X

 D @ACDPTVS,END

 Q

 ;

V ; Run by visit date

 S X1=ACDBD,X2=-1 D C^%DTC S ACDSD=X

 S ACDODAT=ACDSD_".9999" F  S ACDODAT=$O(^ACDVIS("B",ACDODAT)) Q:ACDODAT=""!((ACDODAT\1)>ACDED)  D V1

 Q

 ;

P ;

 S ACDR=0 F  S ACDR=$O(^ACDVIS("D",ACDR)) Q:ACDR'=+ACDR  I '$P(^DPT(ACDR,0),U,19) S DFN=ACDR D PROC

 Q

 ;

 ;

END ;

 S ACDET=$H

 D EOJ

 Q

EOJ ;

 Q

V1 ;

 S ACDR="" F  S ACDR=$O(^ACDVIS("B",ACDODAT,ACDR)) Q:ACDR'=+ACDR  I $D(^ACDVIS(ACDR,0)) S ACDR0=^ACDVIS(ACDR,0),DFN=$P(ACDR0,U,5) D PROC,EOJ

 Q

PROC ;

 I ACDPTVS="P",DFN="" Q

 D SCREENS

 Q:$D(ACDSKIP)

 K ACDSRT,ACDPRNT S ACDCRIT=ACDSORT,ACDX=0 X:$D(^ACDTITEM(ACDSORT,5)) ^ACDTITEM(ACDSORT,5) I $G(ACDPRNT)="" D

 . ;I ACDPTVS="V" S Y=$P($P(ACDR0,U),".") D DD^%DT S ACDPRNT=Y Q

 . ;S ACDPRNT=$P(^DPT(DFN,0),U)

 . S ACDPRNT="--"

 . Q

 S ACDSRT=ACDPRNT

 I '$D(ACDRDTR) S ^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRT,ACDR)="",ACDRCNT=ACDRCNT+1

 I $D(ACDRDTR) S ^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRT,DFN)="",ACDRCNT=ACDRCNT+1

 Q:'$G(DFN)

 Q:$D(^TMP("ACDRL",ACDJOB,ACDBTH,"PATIENTS",DFN))

 S ^TMP("ACDRL",ACDJOB,ACDBTH,"PATIENTS",DFN)="",ACDPTCT=ACDPTCT+1

 Q

SCREENS ;

 K ACDSKIP

 S ACDI=0 F  S ACDI=$O(^ACDRPTD(ACDRPT,11,ACDI)) Q:ACDI'=+ACDI!($D(ACDSKIP))  D

 .I '$P(^ACDTITEM(ACDI,0),U,8) D SINGLE Q

 .D MULT

 .Q

 Q

SINGLE ;

 K X,ACDSPEC S X="",ACDX=0

 X:$D(^ACDTITEM(ACDI,1)) ^(1)

 I X="" S ACDSKIP="" Q

 I '$D(ACDSPEC),'$D(^ACDRPTD(ACDRPT,11,ACDI,11,"B",X)) S ACDSKIP="" Q

 Q

MULT ;

 K ACDFOUN,ACDSKIP,ACDSPEC,X S ACDX=0,X=""

 X:$D(^ACDTITEM(ACDI,1)) ^(1)

 I $O(X(""))="" S ACDSKIP="" Q

 I '$D(ACDSPEC) S Y="" F  S Y=$O(X(Y)) Q:Y=""  I $D(^ACDRPTD(ACDRPT,11,ACDI,11,"B",Y)) S ACDFOUN="" Q

 I $D(ACDSPEC),$D(X) S ACDFOUN=1 Q

 S:'$D(ACDFOUN) ACDSKIP=""

 Q

XIT ;EP - CALLED FROM ACDRL

 K ACD,ACDA,ACDACE,ACDANS,ACDBD,ACDBDD,ACDBT,ACDBTH,ACDC,ACDCAND,ACDCNT,ACDCRIT,ACDCTYP,ACDCUT,ACDD,ACDDA,ACDDASH,ACDDFET,ACDDISP,ACDDONE,ACDED,ACDEDD,ACDEN1,ACDEP1,ACDEP2,ACDET,ACDFIEL,ACDFILE,ACDFLG,ACDFOUN,ACDFRST

 K ACDG,ACDGBD,ACDGBE,ACDGBS,ACDGDB,ACDGDE,ACDGDS,ACDH,ACDHDR,ACDHEAD,ACDHIGH,ACDI,ACDJD,ACDJOB,ACDL,ACDLENG,ACDLHDR,ACDLINE,ACDM,ACDMIFN,ACDNAME,ACDNFIFN,ACDNODE,ACDODAT,ACDPACK,ACDPCNT,ACDPG,ACDPRNM,ACDPRNT,ACDPTCT,ACDPTVS

 K ACDQ,ACDQFLG,ACDQMAN,ACDQUIT,ACDR,ACDRAR,ACDRCNT,ACDRDTR,ACDREC,ACDRIEN,ACDRPT,ACDRREC,ACDS,ACDSAVE,ACDSD,ACDSEL,ACDSKIP,ACDSORT,ACDSORV,ACDSORX,ACDSPAG,ACDSPEC,ACDSRT,ACDSRTR

 K ACDSRTV,ACDTCW,ACDTEST,ACDTEXT,ACDTITL,ACDTL,ACDTMP,ACDTS,ACDTX,ACDX,ACDXREF,ACDY,ACDSCNT

 K AMQQTAX

 D KILL^AUPNPAT

 K C,D,D0,D1,DA,%,%1,%D,%E,%H,%W,%X,%Y,A,DD,DDH,DFN,DI,DIADD,DIC,DICR,DIE,DIFLD,DIG,DIH,DIK,DINUM,DIQ,DIR,DIRUT,DISYS,DIU,DIV,DIW,DIWF,DIWL,DIWR,DIY,DK,DL,DLAYGO,DO,DQ,DR,F,F1,F2,H,I,J,K,L,M,P,POP,S,TS,V,X,X1,X2,Y,Z

XIT1 ;EP

 K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,ACDPACK,ACDEP1,ACDEP2,D,ACDLENG,ACDLHDR,ACDSAVE

 Q

ACDRL1    ;IHS/ADC/EDE/KML - PROCESS RECORD LIST;

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

 +2       ;

 +3       ;

 +4       ;

START     ;

 +1        SET (ACDBT,ACDBTH)=$HOROLOG

           SET ACDJOB=$JOB

           SET ACDRCNT=0

 +2        IF $DATA(ACDRDTR)

               IF ACDPTVS="P"

                   SET X1=ACDBD

                   SET X2=-1

                   DO C^%DTC

                   SET ACDSD=X

 +3        DO @ACDPTVS

           DO END

 +4        QUIT 

 +5       ;

V         ; Run by visit date

 +1        SET X1=ACDBD

           SET X2=-1

           DO C^%DTC

           SET ACDSD=X

 +2        SET ACDODAT=ACDSD_".9999"

           FOR 

               SET ACDODAT=$ORDER(^ACDVIS("B",ACDODAT))

               IF ACDODAT=""!((ACDODAT\1)>ACDED)

                   QUIT 

               DO V1

 +3        QUIT 

 +4       ;

P         ;

 +1        SET ACDR=0

           FOR 

               SET ACDR=$ORDER(^ACDVIS("D",ACDR))

               IF ACDR'=+ACDR

                   QUIT 

               IF '$PIECE(^DPT(ACDR,0),U,19)

                   SET DFN=ACDR

                   DO PROC

 +2        QUIT 

 +3       ;

 +4       ;

END       ;

 +1        SET ACDET=$HOROLOG

 +2        DO EOJ

 +3        QUIT 

EOJ       ;

 +1        QUIT 

V1        ;

 +1        SET ACDR=""

           FOR 

               SET ACDR=$ORDER(^ACDVIS("B",ACDODAT,ACDR))

               IF ACDR'=+ACDR

                   QUIT 

               IF $DATA(^ACDVIS(ACDR,0))

                   SET ACDR0=^ACDVIS(ACDR,0)

                   SET DFN=$PIECE(ACDR0,U,5)

                   DO PROC

                   DO EOJ

 +2        QUIT 

PROC      ;

 +1        IF ACDPTVS="P"

               IF DFN=""

                   QUIT 

 +2        DO SCREENS

 +3        IF $DATA(ACDSKIP)

               QUIT 

 +4        KILL ACDSRT,ACDPRNT

           SET ACDCRIT=ACDSORT

           SET ACDX=0

           IF $DATA(^ACDTITEM(ACDSORT,5))

               XECUTE ^ACDTITEM(ACDSORT,5)

           IF $GET(ACDPRNT)=""

               Begin DoDot:1

 +5       ;I ACDPTVS="V" S Y=$P($P(ACDR0,U),".") D DD^%DT S ACDPRNT=Y Q

 +6       ;S ACDPRNT=$P(^DPT(DFN,0),U)

 +7                SET ACDPRNT="--"

 +8                QUIT 

               End DoDot:1

 +9        SET ACDSRT=ACDPRNT

 +10       IF '$DATA(ACDRDTR)

               SET ^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRT,ACDR)=""

               SET ACDRCNT=ACDRCNT+1

 +11       IF $DATA(ACDRDTR)

               SET ^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRT,DFN)=""

               SET ACDRCNT=ACDRCNT+1

 +12       IF '$GET(DFN)

               QUIT 

 +13       IF $DATA(^TMP("ACDRL",ACDJOB,ACDBTH,"PATIENTS",DFN))

               QUIT 

 +14       SET ^TMP("ACDRL",ACDJOB,ACDBTH,"PATIENTS",DFN)=""

           SET ACDPTCT=ACDPTCT+1

 +15       QUIT 

SCREENS   ;

 +1        KILL ACDSKIP

 +2        SET ACDI=0

           FOR 

               SET ACDI=$ORDER(^ACDRPTD(ACDRPT,11,ACDI))

               IF ACDI'=+ACDI!($DATA(ACDSKIP))

                   QUIT 

               Begin DoDot:1

 +3                IF '$PIECE(^ACDTITEM(ACDI,0),U,8)

                       DO SINGLE

                       QUIT 

 +4                DO MULT

 +5                QUIT 

               End DoDot:1

 +6        QUIT 

SINGLE    ;

 +1        KILL X,ACDSPEC

           SET X=""

           SET ACDX=0

 +2        IF $DATA(^ACDTITEM(ACDI,1))

               XECUTE ^(1)

 +3        IF X=""

               SET ACDSKIP=""

               QUIT 

 +4        IF '$DATA(ACDSPEC)

               IF '$DATA(^ACDRPTD(ACDRPT,11,ACDI,11,"B",X))

                   SET ACDSKIP=""

                   QUIT 

 +5        QUIT 

MULT      ;

 +1        KILL ACDFOUN,ACDSKIP,ACDSPEC,X

           SET ACDX=0

           SET X=""

 +2        IF $DATA(^ACDTITEM(ACDI,1))

               XECUTE ^(1)

 +3        IF $ORDER(X(""))=""

               SET ACDSKIP=""

               QUIT 

 +4        IF '$DATA(ACDSPEC)

               SET Y=""

               FOR 

                   SET Y=$ORDER(X(Y))

                   IF Y=""

                       QUIT 

                   IF $DATA(^ACDRPTD(ACDRPT,11,ACDI,11,"B",Y))

                       SET ACDFOUN=""

                       QUIT 

 +5        IF $DATA(ACDSPEC)

               IF $DATA(X)

                   SET ACDFOUN=1

                   QUIT 

 +6        IF '$DATA(ACDFOUN)

               SET ACDSKIP=""

 +7        QUIT 

XIT       ;EP - CALLED FROM ACDRL

 +1        KILL ACD,ACDA,ACDACE,ACDANS,ACDBD,ACDBDD,ACDBT,ACDBTH,ACDC,ACDCAND,ACDCNT,ACDCRIT,ACDCTYP,ACDCUT,ACDD,ACDDA,ACDDASH,ACDDFET,ACDDISP,ACDDONE,ACDED,ACDEDD,ACDEN1,ACDEP1,ACDEP2,ACDET,ACDFIEL,ACDFILE,ACDFLG,ACDFOUN,ACDFRST

 +2        KILL ACDG,ACDGBD,ACDGBE,ACDGBS,ACDGDB,ACDGDE,ACDGDS,ACDH,ACDHDR,ACDHEAD,ACDHIGH,ACDI,ACDJD,ACDJOB,ACDL,ACDLENG,ACDLHDR,ACDLINE,ACDM,ACDMIFN,ACDNAME,ACDNFIFN,ACDNODE,ACDODAT,ACDPACK,ACDPCNT,ACDPG,ACDPRNM,ACDPRNT,ACDPTCT,ACDPTVS

 +3        KILL ACDQ,ACDQFLG,ACDQMAN,ACDQUIT,ACDR,ACDRAR,ACDRCNT,ACDRDTR,ACDREC,ACDRIEN,ACDRPT,ACDRREC,ACDS,ACDSAVE,ACDSD,ACDSEL,ACDSKIP,ACDSORT,ACDSORV,ACDSORX,ACDSPAG,ACDSPEC,ACDSRT,ACDSRTR

 +4        KILL ACDSRTV,ACDTCW,ACDTEST,ACDTEXT,ACDTITL,ACDTL,ACDTMP,ACDTS,ACDTX,ACDX,ACDXREF,ACDY,ACDSCNT

 +5        KILL AMQQTAX

 +6        DO KILL^AUPNPAT

 +7        KILL C,D,D0,D1,DA,%,%1,%D,%E,%H,%W,%X,%Y,A,DD,DDH,DFN,DI,DIADD,DIC,DICR,DIE,DIFLD,DIG,DIH,DIK,DINUM,DIQ,DIR,DIRUT,DISYS,DIU,DIV,DIW,DIWF,DIWL,DIWR,DIY,DK,DL,DLAYGO,DO,DQ,DR,F,F1,F2,H,I,J,K,L,M,P,POP,S,TS,V,X,X1,X2,Y,Z

XIT1      ;EP

 +1        KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,ACDPACK,ACDEP1,ACDEP2,D,ACDLENG,ACDLHDR,ACDSAVE

 +2        QUIT