ACDRLP ;IHS/ADC/EDE/KML - PRINT CDMIS RECORD REPORT;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
START ;EP - Set up header line, dash line
K ^TMP("ACDFLAT",$J) ;just in case
S X=0,ACDHEAD="" F S X=$O(^ACDRPTD(ACDRPT,12,X)) Q:X'=+X S ACDHDR=$P(^ACDTITEM($P(^ACDRPTD(ACDRPT,12,X,0),U),0),U,6),ACDLENG=$P(^ACDRPTD(ACDRPT,12,X,0),U,2),ACDHDR=$E(ACDHDR,1,ACDLENG) D
.S J=$L(ACDHDR),ACDHEAD=ACDHEAD_ACDHDR,K=$P(^ACDRPTD(ACDRPT,12,X,0),U,2)+1 F I=J:1:K S ACDHEAD=ACDHEAD_" "
.Q
S ACDDASH="",$P(ACDDASH,"-",ACDTCW)="-"
D COVPAGE^ACDRLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
PROC ;process printing of report
I ACDCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done
S ACDPG=0 I '$D(^TMP("ACDRL",ACDJOB,ACDBTH)) G DONE
S (ACDSRTV,ACDFRST)="" K ACDQUIT
F S ACDSRTV=$O(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV)) Q:ACDSRTV=""!($D(ACDQUIT)) D V
G:$D(ACDQUIT) DONE
I ACDCTYP="F" D WRITEF G DONE
I $Y>(IOSL-4) D HEAD G:$D(ACDQUIT) DONE
I $D(ACDRCNT),ACDPTVS="V" W !!!,"Total ",$S(ACDPTVS="P":"Patients",1:"Records"),": ",ACDRCNT
W !!,"Total Patients: ",ACDPTCT
DONE ;
D DONE^ACDRLP2
Q
V ;GETS DATA HITS
S ACDSCNT=0
;get readable sort value
K ACDPRNT S ACDSRTR="",ACDR=$O(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV,"")) I ACDR]"" S ACDCRIT=ACDSORT D
.I ACDPTVS="V" S ACDR0=^ACDVIS(ACDR,0),DFN=$P(ACDR0,U,5) X:$D(^ACDTITEM(ACDSORT,3)) ^(3) S ACDSRTR=$S($G(ACDPRNT)]"":ACDPRNT,1:"--")
.I ACDPTVS="P" S DFN=ACDR X:$D(^ACDTITEM(ACDSORT,3)) ^(3) S ACDSRTR=$S($G(ACDPRNT)]"":ACDPRNT,1:"--")
I $G(ACDSPAG)!($D(ACDFRST)) D HEAD Q:$D(ACDQUIT)
K ACDFRST
S ACDR=0 F S ACDR=$O(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV,ACDR)) Q:ACDR'=+ACDR!($D(ACDQUIT)) D
.I ACDPTVS="V" S ACDR0=^ACDVIS(ACDR,0),DFN=$P(ACDR0,U,5) D PRINT Q
.S DFN=ACDR D PRINT
.Q
Q:$D(ACDQUIT)
I $Y>(IOSL-3) D HEAD Q:$D(ACDQUIT)
W:$G(ACDSPAG) !!,"SUB-TOTAL for ",ACDSORV," ",ACDSRTR,": ",ACDSCNT
W:ACDCTYP="S" !?10,$E(ACDSRTR,1,30),?45,$J(ACDSCNT,8)
Q
PRINT ;
I ACDCTYP="F" D FLAT Q
S ACDSCNT=ACDSCNT+1 Q:ACDCTYP="S"
K ^TMP("ACDLINE",$J) S ^TMP("ACDLINE",$J,1)=""
I $Y>(IOSL-5) D HEAD Q:$D(ACDQUIT)
S ACDI=0 F S ACDI=$O(^ACDRPTD(ACDRPT,12,ACDI)) Q:ACDI'=+ACDI!($D(ACDQUIT)) S ACDCRIT=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U) D
.I '$P(^ACDTITEM(ACDCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
S ACDX=0 F S ACDX=$O(^TMP("ACDLINE",$J,ACDX)) Q:ACDX'=+ACDX!($D(ACDQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(ACDQUIT)
.W !,^TMP("ACDLINE",$J,ACDX)
Q
SINGLE ;process single valued item
K ACDPRNT
S ACDX=0
X:$D(^ACDTITEM(ACDCRIT,3)) ^(3)
I $G(ACDPRNT)="" S ACDPRNT="--"
S ACDLENG=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2),ACDPRNT=$E($G(ACDPRNT),1,ACDLENG) D
.S J=$L(ACDPRNT),^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_ACDPRNT,K=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1 F I=J:1:K S ^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_" "
.S X=1 F S X=$O(^TMP("ACDLINE",$J,X)) Q:X'=+X I $L(^TMP("ACDLINE",$J,X))<$L(^TMP("ACDLINE",$J,1)) S K=$L(^TMP("ACDLINE",$J,X))+1,J=$L(^TMP("ACDLINE",$J,1)) F I=K:1:J S ^TMP("ACDLINE",$J,X)=^TMP("ACDLINE",$J,X)_" "
Q
MULT ;
K ACDPRNT,ACDPRNM S (ACDX,ACDPCNT)=0
X:$D(^ACDTITEM(ACDCRIT,3)) ^(3)
I '$D(ACDPRNM) S ACDPRNT="--" D
.S ACDLENG=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2),ACDPRNT=$E(ACDPRNT,1,ACDLENG) D
..S J=$L(ACDPRNT),^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_ACDPRNT,K=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1 F I=J:1:K S ^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_" "
S X=0 F S X=$O(ACDPRNM(X)) Q:X'=+X D
.I X=1 D Q
..S ACDLENG=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2),ACDPRNT=$E(ACDPRNM(1),1,ACDLENG) D
...S J=$L(ACDPRNT),^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_ACDPRNT,K=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1 F I=J:1:K S ^TMP("ACDLINE",$J,1)=^TMP("ACDLINE",$J,1)_" "
.S ACDLENG=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2),ACDPRNT=$E(ACDPRNM(X),1,ACDLENG) D
..I '$D(^TMP("ACDLINE",$J,X)) S ^TMP("ACDLINE",$J,X)="",K=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1,$P(^TMP("ACDLINE",$J,X)," ",($L(^TMP("ACDLINE",$J,1))-K))=""
..S J=$L(ACDPRNT),^TMP("ACDLINE",$J,X)=^TMP("ACDLINE",$J,X)_ACDPRNT,K=$P(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1 F I=J:1:K S ^TMP("ACDLINE",$J,X)=^TMP("ACDLINE",$J,X)_" "
S X=1 F S X=$O(^TMP("ACDLINE",$J,X)) Q:X'=+X I $L(^TMP("ACDLINE",$J,X))<$L(^TMP("ACDLINE",$J,1)) S K=$L(^TMP("ACDLINE",$J,X))+1,J=$L(^TMP("ACDLINE",$J,1)) F I=K:1:J S ^TMP("ACDLINE",$J,X)=^TMP("ACDLINE",$J,X)_" "
Q
DIQ ;
K ACDPRNT,ACDFILE,ACDFIEL
S ACDFILE=$P($P(^ACDTITEM(ACDCRIT,0),U,4),","),ACDFIEL=$P($P(^(0),U,4),",",2)
S DIQ(0)="EN",DIQ="ACDPRNT(",DIC=ACDFILE,DR=ACDFIEL D EN^DIQ1 K DIC,DR,DIQ
I '$D(ACDPRNT(ACDFILE,DA,ACDFIEL,"E")) S ACDPRNT(ACDFILE,DA,ACDFIEL,"E")="--"
S ACDPRNT=ACDPRNT(ACDFILE,DA,ACDFIEL,"E")
Q
FLAT ;
S E=$$FLAT^ACDFLAT2(ACDR,.ACDREC)
I E S X=0 F S X=$O(ACDREC(X)) Q:X'=+X S ^TMP($J,"ACDFLAT",ACDR)=ACDREC(X)
K ACDTX,ACDREC,X
Q
HEAD ;ENTRY POINT
Q:ACDCTYP="F"
D HEAD^ACDRLP2
Q
WRITEF ;write flat file from global
D WRITEF^ACDRLP2
Q
ACDRLP ;IHS/ADC/EDE/KML - PRINT CDMIS RECORD REPORT;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
START ;EP - Set up header line, dash line
+1 ;just in case
KILL ^TMP("ACDFLAT",$JOB)
+2 SET X=0
SET ACDHEAD=""
FOR
SET X=$ORDER(^ACDRPTD(ACDRPT,12,X))
IF X'=+X
QUIT
SET ACDHDR=$PIECE(^ACDTITEM($PIECE(^ACDRPTD(ACDRPT,12,X,0),U),0),U,6)
SET ACDLENG=$PIECE(^ACDRPTD(ACDRPT,12,X,0),U,2)
SET ACDHDR=$EXTRACT(ACDHDR,1,ACDLENG)
Begin DoDot:1
+3 SET J=$LENGTH(ACDHDR)
SET ACDHEAD=ACDHEAD_ACDHDR
SET K=$PIECE(^ACDRPTD(ACDRPT,12,X,0),U,2)+1
FOR I=J:1:K
SET ACDHEAD=ACDHEAD_" "
+4 QUIT
End DoDot:1
+5 SET ACDDASH=""
SET $PIECE(ACDDASH,"-",ACDTCW)="-"
+6 ;print cover page - note: if user ^'s out of cover page, processing continues
DO COVPAGE^ACDRLP1
PROC ;process printing of report
+1 ;--- if displaying only total, that was done in the cover page - go to done
IF ACDCTYP="T"
GOTO DONE
+2 SET ACDPG=0
IF '$DATA(^TMP("ACDRL",ACDJOB,ACDBTH))
GOTO DONE
+3 SET (ACDSRTV,ACDFRST)=""
KILL ACDQUIT
+4 FOR
SET ACDSRTV=$ORDER(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV))
IF ACDSRTV=""!($DATA(ACDQUIT))
QUIT
DO V
+5 IF $DATA(ACDQUIT)
GOTO DONE
+6 IF ACDCTYP="F"
DO WRITEF
GOTO DONE
+7 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(ACDQUIT)
GOTO DONE
+8 IF $DATA(ACDRCNT)
IF ACDPTVS="V"
WRITE !!!,"Total ",$SELECT(ACDPTVS="P":"Patients",1:"Records"),": ",ACDRCNT
+9 WRITE !!,"Total Patients: ",ACDPTCT
DONE ;
+1 DO DONE^ACDRLP2
+2 QUIT
V ;GETS DATA HITS
+1 SET ACDSCNT=0
+2 ;get readable sort value
+3 KILL ACDPRNT
SET ACDSRTR=""
SET ACDR=$ORDER(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV,""))
IF ACDR]""
SET ACDCRIT=ACDSORT
Begin DoDot:1
+4 IF ACDPTVS="V"
SET ACDR0=^ACDVIS(ACDR,0)
SET DFN=$PIECE(ACDR0,U,5)
IF $DATA(^ACDTITEM(ACDSORT,3))
XECUTE ^(3)
SET ACDSRTR=$SELECT($GET(ACDPRNT)]"":ACDPRNT,1:"--")
+5 IF ACDPTVS="P"
SET DFN=ACDR
IF $DATA(^ACDTITEM(ACDSORT,3))
XECUTE ^(3)
SET ACDSRTR=$SELECT($GET(ACDPRNT)]"":ACDPRNT,1:"--")
End DoDot:1
+6 IF $GET(ACDSPAG)!($DATA(ACDFRST))
DO HEAD
IF $DATA(ACDQUIT)
QUIT
+7 KILL ACDFRST
+8 SET ACDR=0
FOR
SET ACDR=$ORDER(^TMP("ACDRL",ACDJOB,ACDBTH,"DATA HITS",ACDSRTV,ACDR))
IF ACDR'=+ACDR!($DATA(ACDQUIT))
QUIT
Begin DoDot:1
+9 IF ACDPTVS="V"
SET ACDR0=^ACDVIS(ACDR,0)
SET DFN=$PIECE(ACDR0,U,5)
DO PRINT
QUIT
+10 SET DFN=ACDR
DO PRINT
+11 QUIT
End DoDot:1
+12 IF $DATA(ACDQUIT)
QUIT
+13 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(ACDQUIT)
QUIT
+14 IF $GET(ACDSPAG)
WRITE !!,"SUB-TOTAL for ",ACDSORV," ",ACDSRTR,": ",ACDSCNT
+15 IF ACDCTYP="S"
WRITE !?10,$EXTRACT(ACDSRTR,1,30),?45,$JUSTIFY(ACDSCNT,8)
+16 QUIT
PRINT ;
+1 IF ACDCTYP="F"
DO FLAT
QUIT
+2 SET ACDSCNT=ACDSCNT+1
IF ACDCTYP="S"
QUIT
+3 KILL ^TMP("ACDLINE",$JOB)
SET ^TMP("ACDLINE",$JOB,1)=""
+4 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(ACDQUIT)
QUIT
+5 SET ACDI=0
FOR
SET ACDI=$ORDER(^ACDRPTD(ACDRPT,12,ACDI))
IF ACDI'=+ACDI!($DATA(ACDQUIT))
QUIT
SET ACDCRIT=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U)
Begin DoDot:1
+6 IF '$PIECE(^ACDTITEM(ACDCRIT,0),U,8)
DO SINGLE
QUIT
+7 DO MULT
+8 QUIT
End DoDot:1
+9 SET ACDX=0
FOR
SET ACDX=$ORDER(^TMP("ACDLINE",$JOB,ACDX))
IF ACDX'=+ACDX!($DATA(ACDQUIT))
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(ACDQUIT)
QUIT
+11 WRITE !,^TMP("ACDLINE",$JOB,ACDX)
End DoDot:1
+12 QUIT
SINGLE ;process single valued item
+1 KILL ACDPRNT
+2 SET ACDX=0
+3 IF $DATA(^ACDTITEM(ACDCRIT,3))
XECUTE ^(3)
+4 IF $GET(ACDPRNT)=""
SET ACDPRNT="--"
+5 SET ACDLENG=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)
SET ACDPRNT=$EXTRACT($GET(ACDPRNT),1,ACDLENG)
Begin DoDot:1
+6 SET J=$LENGTH(ACDPRNT)
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_ACDPRNT
SET K=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1
FOR I=J:1:K
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_" "
+7 SET X=1
FOR
SET X=$ORDER(^TMP("ACDLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^TMP("ACDLINE",$JOB,X))<$LENGTH(^TMP("ACDLINE",$JOB,1))
SET K=$LENGTH(^TMP("ACDLINE",$JOB,X))+1
SET J=$LENGTH(^TMP("ACDLINE",$JOB,1))
FOR I=K:1:J
SET ^TMP("ACDLINE",$JOB,X)=^TMP("ACDLINE",$JOB,X)_" "
End DoDot:1
+8 QUIT
MULT ;
+1 KILL ACDPRNT,ACDPRNM
SET (ACDX,ACDPCNT)=0
+2 IF $DATA(^ACDTITEM(ACDCRIT,3))
XECUTE ^(3)
+3 IF '$DATA(ACDPRNM)
SET ACDPRNT="--"
Begin DoDot:1
+4 SET ACDLENG=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)
SET ACDPRNT=$EXTRACT(ACDPRNT,1,ACDLENG)
Begin DoDot:2
+5 SET J=$LENGTH(ACDPRNT)
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_ACDPRNT
SET K=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1
FOR I=J:1:K
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_" "
End DoDot:2
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(ACDPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF X=1
Begin DoDot:2
+8 SET ACDLENG=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)
SET ACDPRNT=$EXTRACT(ACDPRNM(1),1,ACDLENG)
Begin DoDot:3
+9 SET J=$LENGTH(ACDPRNT)
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_ACDPRNT
SET K=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1
FOR I=J:1:K
SET ^TMP("ACDLINE",$JOB,1)=^TMP("ACDLINE",$JOB,1)_" "
End DoDot:3
End DoDot:2
QUIT
+10 SET ACDLENG=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)
SET ACDPRNT=$EXTRACT(ACDPRNM(X),1,ACDLENG)
Begin DoDot:2
+11 IF '$DATA(^TMP("ACDLINE",$JOB,X))
SET ^TMP("ACDLINE",$JOB,X)=""
SET K=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1
SET $PIECE(^TMP("ACDLINE",$JOB,X)," ",($LENGTH(^TMP("ACDLINE",$JOB,1))-K))=""
+12 SET J=$LENGTH(ACDPRNT)
SET ^TMP("ACDLINE",$JOB,X)=^TMP("ACDLINE",$JOB,X)_ACDPRNT
SET K=$PIECE(^ACDRPTD(ACDRPT,12,ACDI,0),U,2)+1
FOR I=J:1:K
SET ^TMP("ACDLINE",$JOB,X)=^TMP("ACDLINE",$JOB,X)_" "
End DoDot:2
End DoDot:1
+13 SET X=1
FOR
SET X=$ORDER(^TMP("ACDLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^TMP("ACDLINE",$JOB,X))<$LENGTH(^TMP("ACDLINE",$JOB,1))
SET K=$LENGTH(^TMP("ACDLINE",$JOB,X))+1
SET J=$LENGTH(^TMP("ACDLINE",$JOB,1))
FOR I=K:1:J
SET ^TMP("ACDLINE",$JOB,X)=^TMP("ACDLINE",$JOB,X)_" "
+14 QUIT
DIQ ;
+1 KILL ACDPRNT,ACDFILE,ACDFIEL
+2 SET ACDFILE=$PIECE($PIECE(^ACDTITEM(ACDCRIT,0),U,4),",")
SET ACDFIEL=$PIECE($PIECE(^(0),U,4),",",2)
+3 SET DIQ(0)="EN"
SET DIQ="ACDPRNT("
SET DIC=ACDFILE
SET DR=ACDFIEL
DO EN^DIQ1
KILL DIC,DR,DIQ
+4 IF '$DATA(ACDPRNT(ACDFILE,DA,ACDFIEL,"E"))
SET ACDPRNT(ACDFILE,DA,ACDFIEL,"E")="--"
+5 SET ACDPRNT=ACDPRNT(ACDFILE,DA,ACDFIEL,"E")
+6 QUIT
FLAT ;
+1 SET E=$$FLAT^ACDFLAT2(ACDR,.ACDREC)
+2 IF E
SET X=0
FOR
SET X=$ORDER(ACDREC(X))
IF X'=+X
QUIT
SET ^TMP($JOB,"ACDFLAT",ACDR)=ACDREC(X)
+3 KILL ACDTX,ACDREC,X
+4 QUIT
HEAD ;ENTRY POINT
+1 IF ACDCTYP="F"
QUIT
+2 DO HEAD^ACDRLP2
+3 QUIT
WRITEF ;write flat file from global
+1 DO WRITEF^ACDRLP2
+2 QUIT
