ACMRLP.m

ACMRLP ; IHS/TUCSON/TMJ - PRINT LISTER REPORT ; [ 06/01/1999  1:40 PM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996

 ;IHS/CMI/LAB - patch 1 tmp to xtmp, flat file

 ;IHS/CMI/LAB - tmp to xtmp

START ;EP - Set up header line, dash line

 K ^TMP("AMHFLAT",$J) ;IHS/CMI/LAB

 I ACMCTYP="F" D FLATP^ACMRLF G DONE ;IHS/CMI/LAB

 S X=0,ACMHEAD="" F  S X=$O(^ACM(58.8,ACMRPT,12,X)) Q:X'=+X  S ACMHDR=$P(^ACM(58.1,$P(^ACM(58.8,ACMRPT,12,X,0),U),0),U,6),ACMLENG=$P(^ACM(58.8,ACMRPT,12,X,0),U,2),ACMHDR=$E(ACMHDR,1,ACMLENG) D

 .S J=$L(ACMHDR),ACMHEAD=ACMHEAD_ACMHDR,K=$P(^ACM(58.8,ACMRPT,12,X,0),U,2)+1 F I=J:1:K S ACMHEAD=ACMHEAD_" "

 .Q

 S ACMDASH="",$P(ACMDASH,"-",ACMTCW)="-"

 D COVPAGE^ACMRLP1 ;print cover page - note: if user ^'s out of cover page, processing continues

PROC ;process printing of report

 I ACMCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done

 S ACMPG=0 I '$D(^XTMP("ACMRL",ACMJOB,ACMBTH)) G DONE

 S (ACMSRTV,ACMFRST)="" K ACMQUIT

 F  S ACMSRTV=$O(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV)) Q:ACMSRTV=""!($D(ACMQUIT))  D V

 G:$D(ACMQUIT) DONE

 I $Y>(IOSL-4) D HEAD G:$D(ACMQUIT) DONE

 I $D(ACMRCNT) W !!!,"Total Patients ",ACMRCNT

DONE ;

 D DONE^ACMRLP2

 Q

V ;GETS DATA HITS

 S ACMSCNT=0

 ;get readable sort value

 S ACMSRTR="",DFN=$O(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV,0)) I DFN]"" S ACMCRIT=ACMSORT D

 .S ACMIFN=$G(^ACM(41,"AC",DFN,ACMRG)) X:$D(^ACM(58.1,ACMSORT,3)) ^(3) S ACMSRTR=ACMPRNT

 I $G(ACMSPAG)!($D(ACMFRST)) D HEAD Q:$D(ACMQUIT)

 K ACMFRST

 S DFN=0 F  S DFN=$O(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV,DFN)) Q:DFN'=+DFN!($D(ACMQUIT))  D

 .S ACMIFN=$G(^ACM(41,"AC",DFN,ACMRG)) D PRINT

 .Q

 Q:$D(ACMQUIT)

 I $Y>(IOSL-3) D HEAD Q:$D(ACMQUIT)

 W:$G(ACMSPAG) !!,"SUB-TOTAL for ",ACMSORV," ",ACMSRTR,":  ",ACMSCNT

 W:ACMCTYP="S" !,?10,$E(ACMSRTR,1,30),?45,$J(ACMSCNT,8)

 Q

PRINT ;

 S ACMSCNT=ACMSCNT+1 Q:ACMCTYP="S"

 K ^XTMP("ACMLINE",$J) S ^XTMP("ACMLINE",$J,1)=""

 I $Y>(IOSL-5) D HEAD Q:$D(ACMQUIT)

 S ACMI=0 F  S ACMI=$O(^ACM(58.8,ACMRPT,12,ACMI)) Q:ACMI'=+ACMI!($D(ACMQUIT))  S ACMCRIT=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U) D

 .I '$P(^ACM(58.1,ACMCRIT,0),U,8) D SINGLE Q

 .D MULT

 .Q

 S ACMX=0 F  S ACMX=$O(^XTMP("ACMLINE",$J,ACMX)) Q:ACMX'=+ACMX!($D(ACMQUIT))  D

 .I $Y>(IOSL-4) D HEAD Q:$D(ACMQUIT)

 .W !,^XTMP("ACMLINE",$J,ACMX)

 Q

SINGLE ;process single valued item

 K ACMPRNT

 S ACMX=0

 X:$D(^ACM(58.1,ACMCRIT,3)) ^(3)

 S ACMLENG=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2),ACMPRNT=$E(ACMPRNT,1,ACMLENG) D

 .S J=$L(ACMPRNT),^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_ACMPRNT,K=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1 F I=J:1:K S ^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_" "

 .S X=1 F  S X=$O(^XTMP("ACMLINE",$J,X)) Q:X'=+X  I $L(^XTMP("ACMLINE",$J,X))<$L(^XTMP("ACMLINE",$J,1)) S K=$L(^XTMP("ACMLINE",$J,X))+1,J=$L(^XTMP("ACMLINE",$J,1)) F I=K:1:J S ^XTMP("ACMLINE",$J,X)=^XTMP("ACMLINE",$J,X)_" "

 Q

MULT ;

 K ACMPRNT,ACMPRNM S (ACMX,ACMPCNT)=0

 X:$D(^ACM(58.1,ACMCRIT,3)) ^(3)

 I '$D(ACMPRNM) S ACMPRNT="--" D

 .S ACMLENG=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2),ACMPRNT=$E(ACMPRNT,1,ACMLENG) D

 ..S J=$L(ACMPRNT),^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_ACMPRNT,K=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1 F I=J:1:K S ^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_" "

 S X=0 F  S X=$O(ACMPRNM(X)) Q:X'=+X  D

 .I X=1 D  Q

 ..S ACMLENG=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2),ACMPRNT=$E(ACMPRNM(1),1,ACMLENG) D

 ...S J=$L(ACMPRNT),^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_ACMPRNT,K=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1 F I=J:1:K S ^XTMP("ACMLINE",$J,1)=^XTMP("ACMLINE",$J,1)_" "

 .S ACMLENG=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2),ACMPRNT=$E(ACMPRNM(X),1,ACMLENG) D

 ..I '$D(^XTMP("ACMLINE",$J,X)) S ^XTMP("ACMLINE",$J,X)="",K=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1,$P(^XTMP("ACMLINE",$J,X)," ",($L(^XTMP("ACMLINE",$J,1))-K))=""

 ..S J=$L(ACMPRNT),^XTMP("ACMLINE",$J,X)=^XTMP("ACMLINE",$J,X)_ACMPRNT,K=$P(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1 F I=J:1:K S ^XTMP("ACMLINE",$J,X)=^XTMP("ACMLINE",$J,X)_" "

 S X=1 F  S X=$O(^XTMP("ACMLINE",$J,X)) Q:X'=+X  I $L(^XTMP("ACMLINE",$J,X))<$L(^XTMP("ACMLINE",$J,1)) S K=$L(^XTMP("ACMLINE",$J,X))+1,J=$L(^XTMP("ACMLINE",$J,1)) F I=K:1:J S ^XTMP("ACMLINE",$J,X)=^XTMP("ACMLINE",$J,X)_" "

 Q

DIQ ;

 K ACMPRNT,ACMFILE,ACMFIEL

 S ACMFILE=$P($P(^ACM(58.1,ACMCRIT,0),U,4),","),ACMFIEL=$P($P(^(0),U,4),",",2)

 S DIQ(0)="EN",DIQ="ACMPRNT(",DIC=ACMFILE,DR=ACMFIEL D EN^DIQ1 K DIC,DR,DIQ

 I '$D(ACMPRNT(ACMFILE,DA,ACMFIEL,"E")) S ACMPRNT(ACMFILE,DA,ACMFIEL,"E")="--"

 S ACMPRNT=ACMPRNT(ACMFILE,DA,ACMFIEL,"E")

 Q

HEAD ;ENTRY POINT

 D HEAD^ACMRLP2

 Q

ACMRLP    ; IHS/TUCSON/TMJ - PRINT LISTER REPORT ; [ 06/01/1999  1:40 PM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996

 +2       ;IHS/CMI/LAB - patch 1 tmp to xtmp, flat file

 +3       ;IHS/CMI/LAB - tmp to xtmp

START     ;EP - Set up header line, dash line

 +1       ;IHS/CMI/LAB

           KILL ^TMP("AMHFLAT",$JOB)

 +2       ;IHS/CMI/LAB

           IF ACMCTYP="F"

               DO FLATP^ACMRLF

               GOTO DONE

 +3        SET X=0

           SET ACMHEAD=""

           FOR 

               SET X=$ORDER(^ACM(58.8,ACMRPT,12,X))

               IF X'=+X

                   QUIT 

               SET ACMHDR=$PIECE(^ACM(58.1,$PIECE(^ACM(58.8,ACMRPT,12,X,0),U),0),U,6)

               SET ACMLENG=$PIECE(^ACM(58.8,ACMRPT,12,X,0),U,2)

               SET ACMHDR=$EXTRACT(ACMHDR,1,ACMLENG)

               Begin DoDot:1

 +4                SET J=$LENGTH(ACMHDR)

                   SET ACMHEAD=ACMHEAD_ACMHDR

                   SET K=$PIECE(^ACM(58.8,ACMRPT,12,X,0),U,2)+1

                   FOR I=J:1:K

                       SET ACMHEAD=ACMHEAD_" "

 +5                QUIT 

               End DoDot:1

 +6        SET ACMDASH=""

           SET $PIECE(ACMDASH,"-",ACMTCW)="-"

 +7       ;print cover page - note: if user ^'s out of cover page, processing continues

           DO COVPAGE^ACMRLP1

PROC      ;process printing of report

 +1       ;--- if displaying only total, that was done in the cover page - go to done

           IF ACMCTYP="T"

               GOTO DONE

 +2        SET ACMPG=0

           IF '$DATA(^XTMP("ACMRL",ACMJOB,ACMBTH))

               GOTO DONE

 +3        SET (ACMSRTV,ACMFRST)=""

           KILL ACMQUIT

 +4        FOR 

               SET ACMSRTV=$ORDER(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV))

               IF ACMSRTV=""!($DATA(ACMQUIT))

                   QUIT 

               DO V

 +5        IF $DATA(ACMQUIT)

               GOTO DONE

 +6        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(ACMQUIT)

                   GOTO DONE

 +7        IF $DATA(ACMRCNT)

               WRITE !!!,"Total Patients ",ACMRCNT

DONE      ;

 +1        DO DONE^ACMRLP2

 +2        QUIT 

V         ;GETS DATA HITS

 +1        SET ACMSCNT=0

 +2       ;get readable sort value

 +3        SET ACMSRTR=""

           SET DFN=$ORDER(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV,0))

           IF DFN]""

               SET ACMCRIT=ACMSORT

               Begin DoDot:1

 +4                SET ACMIFN=$GET(^ACM(41,"AC",DFN,ACMRG))

                   IF $DATA(^ACM(58.1,ACMSORT,3))

                       XECUTE ^(3)

                   SET ACMSRTR=ACMPRNT

               End DoDot:1

 +5        IF $GET(ACMSPAG)!($DATA(ACMFRST))

               DO HEAD

               IF $DATA(ACMQUIT)

                   QUIT 

 +6        KILL ACMFRST

 +7        SET DFN=0

           FOR 

               SET DFN=$ORDER(^XTMP("ACMRL",ACMJOB,ACMBTH,"DATA HITS",ACMSRTV,DFN))

               IF DFN'=+DFN!($DATA(ACMQUIT))

                   QUIT 

               Begin DoDot:1

 +8                SET ACMIFN=$GET(^ACM(41,"AC",DFN,ACMRG))

                   DO PRINT

 +9                QUIT 

               End DoDot:1

 +10       IF $DATA(ACMQUIT)

               QUIT 

 +11       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(ACMQUIT)

                   QUIT 

 +12       IF $GET(ACMSPAG)

               WRITE !!,"SUB-TOTAL for ",ACMSORV," ",ACMSRTR,":  ",ACMSCNT

 +13       IF ACMCTYP="S"

               WRITE !,?10,$EXTRACT(ACMSRTR,1,30),?45,$JUSTIFY(ACMSCNT,8)

 +14       QUIT 

PRINT     ;

 +1        SET ACMSCNT=ACMSCNT+1

           IF ACMCTYP="S"

               QUIT 

 +2        KILL ^XTMP("ACMLINE",$JOB)

           SET ^XTMP("ACMLINE",$JOB,1)=""

 +3        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(ACMQUIT)

                   QUIT 

 +4        SET ACMI=0

           FOR 

               SET ACMI=$ORDER(^ACM(58.8,ACMRPT,12,ACMI))

               IF ACMI'=+ACMI!($DATA(ACMQUIT))

                   QUIT 

               SET ACMCRIT=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U)

               Begin DoDot:1

 +5                IF '$PIECE(^ACM(58.1,ACMCRIT,0),U,8)

                       DO SINGLE

                       QUIT 

 +6                DO MULT

 +7                QUIT 

               End DoDot:1

 +8        SET ACMX=0

           FOR 

               SET ACMX=$ORDER(^XTMP("ACMLINE",$JOB,ACMX))

               IF ACMX'=+ACMX!($DATA(ACMQUIT))

                   QUIT 

               Begin DoDot:1

 +9                IF $Y>(IOSL-4)

                       DO HEAD

                       IF $DATA(ACMQUIT)

                           QUIT 

 +10               WRITE !,^XTMP("ACMLINE",$JOB,ACMX)

               End DoDot:1

 +11       QUIT 

SINGLE    ;process single valued item

 +1        KILL ACMPRNT

 +2        SET ACMX=0

 +3        IF $DATA(^ACM(58.1,ACMCRIT,3))

               XECUTE ^(3)

 +4        SET ACMLENG=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)

           SET ACMPRNT=$EXTRACT(ACMPRNT,1,ACMLENG)

           Begin DoDot:1

 +5            SET J=$LENGTH(ACMPRNT)

               SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_ACMPRNT

               SET K=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1

               FOR I=J:1:K

                   SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_" "

 +6            SET X=1

               FOR 

                   SET X=$ORDER(^XTMP("ACMLINE",$JOB,X))

                   IF X'=+X

                       QUIT 

                   IF $LENGTH(^XTMP("ACMLINE",$JOB,X))<$LENGTH(^XTMP("ACMLINE",$JOB,1))

                       SET K=$LENGTH(^XTMP("ACMLINE",$JOB,X))+1

                       SET J=$LENGTH(^XTMP("ACMLINE",$JOB,1))

                       FOR I=K:1:J

                           SET ^XTMP("ACMLINE",$JOB,X)=^XTMP("ACMLINE",$JOB,X)_" "

           End DoDot:1

 +7        QUIT 

MULT      ;

 +1        KILL ACMPRNT,ACMPRNM

           SET (ACMX,ACMPCNT)=0

 +2        IF $DATA(^ACM(58.1,ACMCRIT,3))

               XECUTE ^(3)

 +3        IF '$DATA(ACMPRNM)

               SET ACMPRNT="--"

               Begin DoDot:1

 +4                SET ACMLENG=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)

                   SET ACMPRNT=$EXTRACT(ACMPRNT,1,ACMLENG)

                   Begin DoDot:2

 +5                    SET J=$LENGTH(ACMPRNT)

                       SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_ACMPRNT

                       SET K=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_" "

                   End DoDot:2

               End DoDot:1

 +6        SET X=0

           FOR 

               SET X=$ORDER(ACMPRNM(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +7                IF X=1

                       Begin DoDot:2

 +8                        SET ACMLENG=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)

                           SET ACMPRNT=$EXTRACT(ACMPRNM(1),1,ACMLENG)

                           Begin DoDot:3

 +9                            SET J=$LENGTH(ACMPRNT)

                               SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_ACMPRNT

                               SET K=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1

                               FOR I=J:1:K

                                   SET ^XTMP("ACMLINE",$JOB,1)=^XTMP("ACMLINE",$JOB,1)_" "

                           End DoDot:3

                       End DoDot:2

                       QUIT 

 +10               SET ACMLENG=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)

                   SET ACMPRNT=$EXTRACT(ACMPRNM(X),1,ACMLENG)

                   Begin DoDot:2

 +11                   IF '$DATA(^XTMP("ACMLINE",$JOB,X))

                           SET ^XTMP("ACMLINE",$JOB,X)=""

                           SET K=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1

                           SET $PIECE(^XTMP("ACMLINE",$JOB,X)," ",($LENGTH(^XTMP("ACMLINE",$JOB,1))-K))=""

 +12                   SET J=$LENGTH(ACMPRNT)

                       SET ^XTMP("ACMLINE",$JOB,X)=^XTMP("ACMLINE",$JOB,X)_ACMPRNT

                       SET K=$PIECE(^ACM(58.8,ACMRPT,12,ACMI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("ACMLINE",$JOB,X)=^XTMP("ACMLINE",$JOB,X)_" "

                   End DoDot:2

               End DoDot:1

 +13       SET X=1

           FOR 

               SET X=$ORDER(^XTMP("ACMLINE",$JOB,X))

               IF X'=+X

                   QUIT 

               IF $LENGTH(^XTMP("ACMLINE",$JOB,X))<$LENGTH(^XTMP("ACMLINE",$JOB,1))

                   SET K=$LENGTH(^XTMP("ACMLINE",$JOB,X))+1

                   SET J=$LENGTH(^XTMP("ACMLINE",$JOB,1))

                   FOR I=K:1:J

                       SET ^XTMP("ACMLINE",$JOB,X)=^XTMP("ACMLINE",$JOB,X)_" "

 +14       QUIT 

DIQ       ;

 +1        KILL ACMPRNT,ACMFILE,ACMFIEL

 +2        SET ACMFILE=$PIECE($PIECE(^ACM(58.1,ACMCRIT,0),U,4),",")

           SET ACMFIEL=$PIECE($PIECE(^(0),U,4),",",2)

 +3        SET DIQ(0)="EN"

           SET DIQ="ACMPRNT("

           SET DIC=ACMFILE

           SET DR=ACMFIEL

           DO EN^DIQ1

           KILL DIC,DR,DIQ

 +4        IF '$DATA(ACMPRNT(ACMFILE,DA,ACMFIEL,"E"))

               SET ACMPRNT(ACMFILE,DA,ACMFIEL,"E")="--"

 +5        SET ACMPRNT=ACMPRNT(ACMFILE,DA,ACMFIEL,"E")

 +6        QUIT 

HEAD      ;ENTRY POINT

 +1        DO HEAD^ACMRLP2

 +2        QUIT