ACDRLP.m

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