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
