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
