APCLVLP ; IHS/CMI/LAB - PRINT VISIT REPORT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;IHS/TUCSON/LAB - added killing of APCLPRNT to V subroutine 05/19/97
;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97
START ;EP - Set up header line, dash line
I APCLCTYP="L" D DELIMIT^APCLVLP8 Q
S APCLFCNT=0
K ^XTMP($J,"APCLFLAT") ;just in case
S X=0,APCLHEAD="" F S X=$O(^APCLVRPT(APCLRPT,12,X)) Q:X'=+X S APCLHDR=$P(^APCLVSTS($P(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6),APCLLENG=$P(^APCLVRPT(APCLRPT,12,X,0),U,2),APCLHDR=$E(APCLHDR,1,APCLLENG) D
.S J=$L(APCLHDR),APCLHEAD=APCLHEAD_APCLHDR,K=$P(^APCLVRPT(APCLRPT,12,X,0),U,2)+1 F I=J:1:K S APCLHEAD=APCLHEAD_" "
.Q
S APCLDASH="",$P(APCLDASH,"-",APCLTCW)="-"
D COVPAGE^APCLVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
PROC ;process printing of report
I APCLCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done
I APCLCTYP="C" G DONE ;--- if doing a template, that's already done so goto done
I APCLCTYP="P" G DONE ; -- template
S APCLPG=0 I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) G DONE
S (APCLSRTV,APCLFRST)="" K APCLQUIT
F S APCLSRTV=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV)) Q:APCLSRTV=""!($D(APCLQUIT)) D V
G:$D(APCLQUIT) DONE
I APCLCTYP="F" D G DONE
.D WRITEF
.W:'$D(ZTQUEUED) !!,"Flat file ",APCLOUTF," has been created."
.W:'$D(ZTQUEUED) !,"Total number of visits counted in selection process: ",APCLRCNT
.W:'$D(ZTQUEUED) !,"Total number of visits that generated Area Database records: ",(APCLFCNT/3) ;IHS/TUCSON/LAB - PATCH 1 - 05/27/97 changed 2 to 3
.W:'$D(ZTQUEUED) !!,"If there is a discrepency in the counts it is because some of the visits",!,"that met the selection criteria may have been incomplete, or ",!,"generated an error while the area database record was being created."
.W:'$D(ZTQUEUED) !,"Errors that could occur would be similar to errors seen on the PCC Visit",!,"review reports.",!
I $Y>(IOSL-4) D HEAD G:$D(APCLQUIT) DONE
I $D(APCLRCNT) W !!!,"Total ",$S(APCLPTVS="P":"Patients",1:"Visits"),": ",APCLRCNT
I $G(APCLPTVS)="V" W !,"Total Patients: ",APCLPTCT
DONE ;
D DONE^APCLVLP2
Q
V ;GETS DATA HITS
S APCLSCNT=0
;get readable sort value
K APCLPRNT ;IHS/TUCSON/LAB - added this kill to prevent wrong value patch 1 05/19/97
S APCLSRTR="",APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,0)) I APCLVIEN]"" S APCLCRIT=APCLSORT D
.I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT
.I APCLPTVS="P" S DFN=APCLVIEN X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT
I $G(APCLSPAG)!($D(APCLFRST)) D HEAD Q:$D(APCLQUIT)
K APCLFRST
S APCLVIEN=0 F S APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN!($D(APCLQUIT)) D
.I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) D PRINT Q
.S DFN=APCLVIEN D PRINT
.Q
Q:$D(APCLQUIT)
I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT)
I $G(APCLSPAG) W !!,"SUB-TOTAL for ",APCLSORV," ",APCLSRTR,": ",APCLSCNT I APCLPTVS="V" W " # of PATIENTS: ",$S($D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),1:0)
I APCLCTYP="S",(APCLPTVS="V") W !,?10,$E(APCLSRTR,1,30),?45,$J(APCLSCNT,8)," (V)",?60,$S($D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):$J(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),8),1:0)," (P)"
I APCLCTYP="S",(APCLPTVS="P") W !,?10,$E(APCLSRTR,1,30),?45,$J(APCLSCNT,8)
Q
PRINT ;
I APCLCTYP="F" D FLAT Q
S APCLSCNT=APCLSCNT+1 Q:APCLCTYP="S"
K ^XTMP("APCLLINE",$J) S ^XTMP("APCLLINE",$J,1)=""
I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,12,APCLI)) Q:APCLI'=+APCLI!($D(APCLQUIT)) S APCLCRIT=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U) D
.I '$P(^APCLVSTS(APCLCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
S APCLX=0 F S APCLX=$O(^XTMP("APCLLINE",$J,APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
.W !,^XTMP("APCLLINE",$J,APCLX)
Q
SINGLE ;process single valued item
K APCLPRNT
S APCLX=0
X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D
.S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" "
.S X=1 F S X=$O(^XTMP("APCLLINE",$J,X)) Q:X'=+X I $L(^XTMP("APCLLINE",$J,X))<$L(^XTMP("APCLLINE",$J,1)) S K=$L(^XTMP("APCLLINE",$J,X))+1,J=$L(^XTMP("APCLLINE",$J,1)) F I=K:1:J S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" "
Q
LABLOINC ;
S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X S Y=$G(APCLPRNM(X,"I")) D
.Q:Y=""
.Q:'$D(^AUPNVLAB(Y,0))
.S Z=$P(^AUPNVLAB(Y,0),U)
.Q:$D(APCLLABT("LAB",Z))
.S J=$P($G(^AUPNVLAB(Y,11)),U,13)
.I J="" K APCLPRNM(X) Q
.I $$LOINC^APCLVLU1(J) Q
.K APCLPRNM(X)
.Q
Q
MULT ;
K APCLPRNT,APCLPRNM,APCLY S (APCLX,APCLPCNT)=0
X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
;if 13th, then $o through delete bad ones and then reorder/number
;new logic here to screen if user wants to screen
I $P(^APCLVRPT(APCLRPT,12,APCLI,0),U,3) D
.;does this one match selected ones?
.I $P(^APCLVSTS(APCLCRIT,0),U,14) D LABLOINC G NEXT
.S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D
..S Z=$G(APCLPRNM(X,"I")) I Z="" K APCLPRNM(X) Q
..I '$D(^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Z)) K APCLPRNM(X)
NEXT ;
K Y S (X,C)=0 F S X=$O(APCLPRNM(X)) Q:X'=+X S C=C+1,Y(C)=APCLPRNM(X)
K APCLPRNM S X=0 F S X=$O(Y(X)) Q:X'=+X S APCLPRNM(X)=Y(X)
I '$D(APCLPRNM) S APCLPRNT="--" D
.S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D
..S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" "
S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D
.I X=1 D Q
..S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(1),1,APCLLENG) D
...S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" "
.S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(X),1,APCLLENG) D
..I '$D(^XTMP("APCLLINE",$J,X)) S ^XTMP("APCLLINE",$J,X)="",K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1,$P(^XTMP("APCLLINE",$J,X)," ",($L(^XTMP("APCLLINE",$J,1))-K))=""
..S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" "
S X=1 F S X=$O(^XTMP("APCLLINE",$J,X)) Q:X'=+X I $L(^XTMP("APCLLINE",$J,X))<$L(^XTMP("APCLLINE",$J,1)) S K=$L(^XTMP("APCLLINE",$J,X))+1,J=$L(^XTMP("APCLLINE",$J,1)) F I=K:1:J S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" "
Q
DIQ ;
K APCLPRNT,APCLFILE,APCLFIEL
S APCLFILE=$P($P(^APCLVSTS(APCLCRIT,0),U,4),","),APCLFIEL=$P($P(^(0),U,4),",",2)
S DIQ(0)="EN",DIQ="APCLPRNT(",DIC=APCLFILE,DR=APCLFIEL D EN^DIQ1 K DIC,DR,DIQ
I '$D(APCLPRNT(APCLFILE,DA,APCLFIEL,"E")) S APCLPRNT(APCLFILE,DA,APCLFIEL,"E")="--"
S APCLPRNT=APCLPRNT(APCLFILE,DA,APCLFIEL,"E")
Q
FLAT ;
;IHS/TUCSON/LAB - modified this subroutine to add a third record patch 1 05/27/97
K APCLX1,APCLX2,APCLX3 ;IHS/TUCSON/LAB - added kill of APCLX3
S APCLX1=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 1")
Q:APCLX1=""
Q:APCLX1=-1
S APCLX2=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 2")
G:APCLX2="" FLATX
G:APCLX2=-1 FLATX
S APCLX3=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 3")
Q:APCLX3=""
G:APCLX3=-1 FLATX
S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX1
S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX2
S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX3
FLATX K APCLX1,APCLX2,APCLV0,APCLX3
Q
HEAD ;ENTRY POINT
D HEAD^APCLVLP2
Q
WRITEF ;write flat file from global
D WRITEF^APCLVLP2
Q
APCLVLP ; IHS/CMI/LAB - PRINT VISIT REPORT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;IHS/TUCSON/LAB - added killing of APCLPRNT to V subroutine 05/19/97
+3 ;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97
START ;EP - Set up header line, dash line
+1 IF APCLCTYP="L"
DO DELIMIT^APCLVLP8
QUIT
+2 SET APCLFCNT=0
+3 ;just in case
KILL ^XTMP($JOB,"APCLFLAT")
+4 SET X=0
SET APCLHEAD=""
FOR
SET X=$ORDER(^APCLVRPT(APCLRPT,12,X))
IF X'=+X
QUIT
SET APCLHDR=$PIECE(^APCLVSTS($PIECE(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6)
SET APCLLENG=$PIECE(^APCLVRPT(APCLRPT,12,X,0),U,2)
SET APCLHDR=$EXTRACT(APCLHDR,1,APCLLENG)
Begin DoDot:1
+5 SET J=$LENGTH(APCLHDR)
SET APCLHEAD=APCLHEAD_APCLHDR
SET K=$PIECE(^APCLVRPT(APCLRPT,12,X,0),U,2)+1
FOR I=J:1:K
SET APCLHEAD=APCLHEAD_" "
+6 QUIT
End DoDot:1
+7 SET APCLDASH=""
SET $PIECE(APCLDASH,"-",APCLTCW)="-"
+8 ;print cover page - note: if user ^'s out of cover page, processing continues
DO COVPAGE^APCLVLP1
PROC ;process printing of report
+1 ;--- if displaying only total, that was done in the cover page - go to done
IF APCLCTYP="T"
GOTO DONE
+2 ;--- if doing a template, that's already done so goto done
IF APCLCTYP="C"
GOTO DONE
+3 ; -- template
IF APCLCTYP="P"
GOTO DONE
+4 SET APCLPG=0
IF '$DATA(^XTMP("APCLVL",APCLJOB,APCLBTH))
GOTO DONE
+5 SET (APCLSRTV,APCLFRST)=""
KILL APCLQUIT
+6 FOR
SET APCLSRTV=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV))
IF APCLSRTV=""!($DATA(APCLQUIT))
QUIT
DO V
+7 IF $DATA(APCLQUIT)
GOTO DONE
+8 IF APCLCTYP="F"
Begin DoDot:1
+9 DO WRITEF
+10 IF '$DATA(ZTQUEUED)
WRITE !!,"Flat file ",APCLOUTF," has been created."
+11 IF '$DATA(ZTQUEUED)
WRITE !,"Total number of visits counted in selection process: ",APCLRCNT
+12 ;IHS/TUCSON/LAB - PATCH 1 - 05/27/97 changed 2 to 3
IF '$DATA(ZTQUEUED)
WRITE !,"Total number of visits that generated Area Database records: ",(APCLFCNT/3)
+13 IF '$DATA(ZTQUEUED)
WRITE !!,"If there is a discrepency in the counts it is because some of the visits",!,"that met the selection criteria may have been incomplete, or ",!,"generated an error while the area database record was being created."
+14 IF '$DATA(ZTQUEUED)
WRITE !,"Errors that could occur would be similar to errors seen on the PCC Visit",!,"review reports.",!
End DoDot:1
GOTO DONE
+15 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
GOTO DONE
+16 IF $DATA(APCLRCNT)
WRITE !!!,"Total ",$SELECT(APCLPTVS="P":"Patients",1:"Visits"),": ",APCLRCNT
+17 IF $GET(APCLPTVS)="V"
WRITE !,"Total Patients: ",APCLPTCT
DONE ;
+1 DO DONE^APCLVLP2
+2 QUIT
V ;GETS DATA HITS
+1 SET APCLSCNT=0
+2 ;get readable sort value
+3 ;IHS/TUCSON/LAB - added this kill to prevent wrong value patch 1 05/19/97
KILL APCLPRNT
+4 SET APCLSRTR=""
SET APCLVIEN=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,0))
IF APCLVIEN]""
SET APCLCRIT=APCLSORT
Begin DoDot:1
+5 IF APCLPTVS="V"
SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
SET DFN=$PIECE(APCLVREC,U,5)
IF $DATA(^APCLVSTS(APCLSORT,3))
XECUTE ^(3)
SET APCLSRTR=APCLPRNT
+6 IF APCLPTVS="P"
SET DFN=APCLVIEN
IF $DATA(^APCLVSTS(APCLSORT,3))
XECUTE ^(3)
SET APCLSRTR=APCLPRNT
End DoDot:1
+7 IF $GET(APCLSPAG)!($DATA(APCLFRST))
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+8 KILL APCLFRST
+9 SET APCLVIEN=0
FOR
SET APCLVIEN=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,APCLVIEN))
IF APCLVIEN'=+APCLVIEN!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+10 IF APCLPTVS="V"
SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
SET DFN=$PIECE(APCLVREC,U,5)
DO PRINT
QUIT
+11 SET DFN=APCLVIEN
DO PRINT
+12 QUIT
End DoDot:1
+13 IF $DATA(APCLQUIT)
QUIT
+14 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+15 IF $GET(APCLSPAG)
WRITE !!,"SUB-TOTAL for ",APCLSORV," ",APCLSRTR,": ",APCLSCNT
IF APCLPTVS="V"
WRITE " # of PATIENTS: ",$SELECT($DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),1:0)
+16 IF APCLCTYP="S"
IF (APCLPTVS="V")
WRITE !,?10,$EXTRACT(APCLSRTR,1,30),?45,$JUSTIFY(APCLSCNT,8)," (V)",?60,$SELECT($DATA(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):$JUSTIFY(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),8),1:0)," (P)"
+17 IF APCLCTYP="S"
IF (APCLPTVS="P")
WRITE !,?10,$EXTRACT(APCLSRTR,1,30),?45,$JUSTIFY(APCLSCNT,8)
+18 QUIT
PRINT ;
+1 IF APCLCTYP="F"
DO FLAT
QUIT
+2 SET APCLSCNT=APCLSCNT+1
IF APCLCTYP="S"
QUIT
+3 KILL ^XTMP("APCLLINE",$JOB)
SET ^XTMP("APCLLINE",$JOB,1)=""
+4 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+5 SET APCLI=0
FOR
SET APCLI=$ORDER(^APCLVRPT(APCLRPT,12,APCLI))
IF APCLI'=+APCLI!($DATA(APCLQUIT))
QUIT
SET APCLCRIT=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U)
Begin DoDot:1
+6 IF '$PIECE(^APCLVSTS(APCLCRIT,0),U,8)
DO SINGLE
QUIT
+7 DO MULT
+8 QUIT
End DoDot:1
+9 SET APCLX=0
FOR
SET APCLX=$ORDER(^XTMP("APCLLINE",$JOB,APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+11 WRITE !,^XTMP("APCLLINE",$JOB,APCLX)
End DoDot:1
+12 QUIT
SINGLE ;process single valued item
+1 KILL APCLPRNT
+2 SET APCLX=0
+3 IF $DATA(^APCLVSTS(APCLCRIT,3))
XECUTE ^(3)
+4 SET APCLLENG=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)
SET APCLPRNT=$EXTRACT(APCLPRNT,1,APCLLENG)
Begin DoDot:1
+5 SET J=$LENGTH(APCLPRNT)
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_APCLPRNT
SET K=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_" "
+6 SET X=1
FOR
SET X=$ORDER(^XTMP("APCLLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^XTMP("APCLLINE",$JOB,X))<$LENGTH(^XTMP("APCLLINE",$JOB,1))
SET K=$LENGTH(^XTMP("APCLLINE",$JOB,X))+1
SET J=$LENGTH(^XTMP("APCLLINE",$JOB,1))
FOR I=K:1:J
SET ^XTMP("APCLLINE",$JOB,X)=^XTMP("APCLLINE",$JOB,X)_" "
End DoDot:1
+7 QUIT
LABLOINC ;
+1 SET X=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
SET Y=$GET(APCLPRNM(X,"I"))
Begin DoDot:1
+2 IF Y=""
QUIT
+3 IF '$DATA(^AUPNVLAB(Y,0))
QUIT
+4 SET Z=$PIECE(^AUPNVLAB(Y,0),U)
+5 IF $DATA(APCLLABT("LAB",Z))
QUIT
+6 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
+7 IF J=""
KILL APCLPRNM(X)
QUIT
+8 IF $$LOINC^APCLVLU1(J)
QUIT
+9 KILL APCLPRNM(X)
+10 QUIT
End DoDot:1
+11 QUIT
MULT ;
+1 KILL APCLPRNT,APCLPRNM,APCLY
SET (APCLX,APCLPCNT)=0
+2 IF $DATA(^APCLVSTS(APCLCRIT,3))
XECUTE ^(3)
+3 ;if 13th, then $o through delete bad ones and then reorder/number
+4 ;new logic here to screen if user wants to screen
+5 IF $PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,3)
Begin DoDot:1
+6 ;does this one match selected ones?
+7 IF $PIECE(^APCLVSTS(APCLCRIT,0),U,14)
DO LABLOINC
GOTO NEXT
+8 SET X=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
Begin DoDot:2
+9 SET Z=$GET(APCLPRNM(X,"I"))
IF Z=""
KILL APCLPRNM(X)
QUIT
+10 IF '$DATA(^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Z))
KILL APCLPRNM(X)
End DoDot:2
End DoDot:1
NEXT ;
+1 KILL Y
SET (X,C)=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
SET C=C+1
SET Y(C)=APCLPRNM(X)
+2 KILL APCLPRNM
SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET APCLPRNM(X)=Y(X)
+3 IF '$DATA(APCLPRNM)
SET APCLPRNT="--"
Begin DoDot:1
+4 SET APCLLENG=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)
SET APCLPRNT=$EXTRACT(APCLPRNT,1,APCLLENG)
Begin DoDot:2
+5 SET J=$LENGTH(APCLPRNT)
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_APCLPRNT
SET K=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_" "
End DoDot:2
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF X=1
Begin DoDot:2
+8 SET APCLLENG=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)
SET APCLPRNT=$EXTRACT(APCLPRNM(1),1,APCLLENG)
Begin DoDot:3
+9 SET J=$LENGTH(APCLPRNT)
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_APCLPRNT
SET K=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("APCLLINE",$JOB,1)=^XTMP("APCLLINE",$JOB,1)_" "
End DoDot:3
End DoDot:2
QUIT
+10 SET APCLLENG=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)
SET APCLPRNT=$EXTRACT(APCLPRNM(X),1,APCLLENG)
Begin DoDot:2
+11 IF '$DATA(^XTMP("APCLLINE",$JOB,X))
SET ^XTMP("APCLLINE",$JOB,X)=""
SET K=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1
SET $PIECE(^XTMP("APCLLINE",$JOB,X)," ",($LENGTH(^XTMP("APCLLINE",$JOB,1))-K))=""
+12 SET J=$LENGTH(APCLPRNT)
SET ^XTMP("APCLLINE",$JOB,X)=^XTMP("APCLLINE",$JOB,X)_APCLPRNT
SET K=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("APCLLINE",$JOB,X)=^XTMP("APCLLINE",$JOB,X)_" "
End DoDot:2
End DoDot:1
+13 SET X=1
FOR
SET X=$ORDER(^XTMP("APCLLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^XTMP("APCLLINE",$JOB,X))<$LENGTH(^XTMP("APCLLINE",$JOB,1))
SET K=$LENGTH(^XTMP("APCLLINE",$JOB,X))+1
SET J=$LENGTH(^XTMP("APCLLINE",$JOB,1))
FOR I=K:1:J
SET ^XTMP("APCLLINE",$JOB,X)=^XTMP("APCLLINE",$JOB,X)_" "
+14 QUIT
DIQ ;
+1 KILL APCLPRNT,APCLFILE,APCLFIEL
+2 SET APCLFILE=$PIECE($PIECE(^APCLVSTS(APCLCRIT,0),U,4),",")
SET APCLFIEL=$PIECE($PIECE(^(0),U,4),",",2)
+3 SET DIQ(0)="EN"
SET DIQ="APCLPRNT("
SET DIC=APCLFILE
SET DR=APCLFIEL
DO EN^DIQ1
KILL DIC,DR,DIQ
+4 IF '$DATA(APCLPRNT(APCLFILE,DA,APCLFIEL,"E"))
SET APCLPRNT(APCLFILE,DA,APCLFIEL,"E")="--"
+5 SET APCLPRNT=APCLPRNT(APCLFILE,DA,APCLFIEL,"E")
+6 QUIT
FLAT ;
+1 ;IHS/TUCSON/LAB - modified this subroutine to add a third record patch 1 05/27/97
+2 ;IHS/TUCSON/LAB - added kill of APCLX3
KILL APCLX1,APCLX2,APCLX3
+3 SET APCLX1=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 1")
+4 IF APCLX1=""
QUIT
+5 IF APCLX1=-1
QUIT
+6 SET APCLX2=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 2")
+7 IF APCLX2=""
GOTO FLATX
+8 IF APCLX2=-1
GOTO FLATX
+9 SET APCLX3=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 3")
+10 IF APCLX3=""
QUIT
+11 IF APCLX3=-1
GOTO FLATX
+12 SET APCLFCNT=APCLFCNT+1
SET ^XTMP($JOB,"APCLFLAT",APCLFCNT)=APCLX1
+13 SET APCLFCNT=APCLFCNT+1
SET ^XTMP($JOB,"APCLFLAT",APCLFCNT)=APCLX2
+14 SET APCLFCNT=APCLFCNT+1
SET ^XTMP($JOB,"APCLFLAT",APCLFCNT)=APCLX3
FLATX KILL APCLX1,APCLX2,APCLV0,APCLX3
+1 QUIT
HEAD ;ENTRY POINT
+1 DO HEAD^APCLVLP2
+2 QUIT
WRITEF ;write flat file from global
+1 DO WRITEF^APCLVLP2
+2 QUIT
