APCLVLP8 ; 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
DELIMIT ;EP - Set up header line, dash line
S APCLFCNT=0
K ^XTMP($J,"APCLFLAT") ;just in case
K ^TMP($J,"APCLDELIMITED")
S APCLDELC=0,APCLPIEC=0
I APCLPTVS="V" S APCLHDR="PATIENT IEN"_U_"VISIT IEN",APCLPIEC=2
I APCLPTVS="P" S APCLHDR="PATIENT IEN",APCLPIEC=1
S X=0,APCLHEAD="" F S X=$O(^APCLVRPT(APCLRPT,12,X)) Q:X'=+X D
.S APCLPIEC=APCLPIEC+1
.S H=$P(^APCLVSTS($P(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6)
.S $P(APCLHDR,U,APCLPIEC)=H
.Q
D COVPAGE^APCLVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
PROC ;process printing of report
I APCLDELT="F" D OPEN Q:Y=1
W !,APCLHDR,!
I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) W !,"NO DATA TO REPORT" G DONE
S (APCLSRTV,APCLFRST)="" K APCLQUIT
F S APCLSRTV=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV)) Q:APCLSRTV=""!($D(APCLQUIT)) D V
DONE ;
;write out delimited file
I APCLDELT="F" D ^%ZISC
K ^XTMP("APCLVL",APCLJOB,APCLBT),^XTMP("APCLFLAT",$J),^TMP($J,"APCLDELIMITED")
D DEL^APCLVL
K APCLBD,APCLSD,APCLED,APCLEDD,APCLBDD,APCLRPT,APCLHEAD,APCLLINE,APCLL,APCLRCNT,APCLI,APCLCRIT,APCLVIEN,APCLVREC,APCLJOB,APCLBT,APCLBTH,APCLQUIT,APCLHDR,APCLDASH,APCLLENG,APCLPCNT,APCLTCW,APCLODAT,APCLPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX
K APCLSORT,APCLSRT,APCLSORX,APCLFILE,APCLFIEL,APCLPRNT,APCLX,APCLTYPE,APCLFOUN,D0,J,K,L,APCLPRNM,APCLTEST,APCLSEAT,APCLLHDR,APCLFRST
D EN^XBVK("APCL")
Q
V ;GETS DATA HITS
S APCLCNT=0
;get readable sort value
K APCLPRNT
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
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
PRINT ;
K ^XTMP("APCLLINE",$J) S ^XTMP("APCLLINE",$J,1)=""
K APCLDELD
S APCLPIEC=0,APCLLINE=1,APCLCNT=APCLCNT+1
I APCLPTVS="V" S APCLDELD(1,"S")=DFN,APCLDELD(2,"S")=APCLVIEN,APCLPIEC=2
I APCLPTVS="P" S APCLDELD(1,"S")=DFN,APCLPIEC=1
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
.S APCLPIEC=APCLPIEC+1
.I '$P(^APCLVSTS(APCLCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
K APCLDELP
F X=1:1:APCLLINE D
.S APCLCNT=APCLCNT+1
.F P=1:1:APCLPIEC D
..S V=$O(APCLDELD(P,""))
..I V="S" S D=APCLDELD(P,V),$P(APCLDELP(APCLCNT),U,P)=D
..I V="M" S D=$S($P(APCLDELD(P,V),"|",X)]"":$P(APCLDELD(P,V),"|",X),1:"--"),$P(APCLDELP(APCLCNT),U,P)=D
S X=0 F S X=$O(APCLDELP(X)) Q:X'=+X W APCLDELP(X),!
Q
SINGLE ;process single valued item
K APCLPRNT
S APCLX=0
X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
I APCLPRNT="" S APCLPRNT="--"
S APCLDELD(APCLPIEC,"S")=APCLPRNT
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?
.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)
K Y S (X,C)=0 F S X=$O(APCLPRNM(X)) Q:X'=+X S C=C+1,Y(C)=APCLPRNM(X)
I C>APCLLINE S APCLLINE=C
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 APCLDELD(APCLPIEC,"M")=APCLPRNT
S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D
.S $P(APCLDELD(APCLPIEC,"M"),"|",X)=APCLPRNM(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
OPEN ;write flat file from global
;if screen selected do screen
;USE GS FROM GPRA TO OPEN AND WRITE FILE
;I APCLDELT="S" D SCREEN Q
S Y=$$OPEN^%ZISH(APCLHDIR,APCLDELF,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file to write out DELIMITED data. Notify programmer." Q
U IO
Q
APCLVLP8 ; 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
DELIMIT ;EP - Set up header line, dash line
+1 SET APCLFCNT=0
+2 ;just in case
KILL ^XTMP($JOB,"APCLFLAT")
+3 KILL ^TMP($JOB,"APCLDELIMITED")
+4 SET APCLDELC=0
SET APCLPIEC=0
+5 IF APCLPTVS="V"
SET APCLHDR="PATIENT IEN"_U_"VISIT IEN"
SET APCLPIEC=2
+6 IF APCLPTVS="P"
SET APCLHDR="PATIENT IEN"
SET APCLPIEC=1
+7 SET X=0
SET APCLHEAD=""
FOR
SET X=$ORDER(^APCLVRPT(APCLRPT,12,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET APCLPIEC=APCLPIEC+1
+9 SET H=$PIECE(^APCLVSTS($PIECE(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6)
+10 SET $PIECE(APCLHDR,U,APCLPIEC)=H
+11 QUIT
End DoDot:1
+12 ;print cover page - note: if user ^'s out of cover page, processing continues
DO COVPAGE^APCLVLP1
PROC ;process printing of report
+1 IF APCLDELT="F"
DO OPEN
IF Y=1
QUIT
+2 WRITE !,APCLHDR,!
+3 IF '$DATA(^XTMP("APCLVL",APCLJOB,APCLBTH))
WRITE !,"NO DATA TO REPORT"
GOTO DONE
+4 SET (APCLSRTV,APCLFRST)=""
KILL APCLQUIT
+5 FOR
SET APCLSRTV=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV))
IF APCLSRTV=""!($DATA(APCLQUIT))
QUIT
DO V
DONE ;
+1 ;write out delimited file
+2 IF APCLDELT="F"
DO ^%ZISC
+3 KILL ^XTMP("APCLVL",APCLJOB,APCLBT),^XTMP("APCLFLAT",$JOB),^TMP($JOB,"APCLDELIMITED")
+4 DO DEL^APCLVL
+5 KILL APCLBD,APCLSD,APCLED,APCLEDD,APCLBDD,APCLRPT,APCLHEAD,APCLLINE,APCLL,APCLRCNT,APCLI,APCLCRIT,APCLVIEN,APCLVREC,APCLJOB,APCLBT,APCLBTH,APCLQUIT,APCLHDR,APCLDASH,APCLLENG,APCLPCNT,APCLTCW,APCLODAT,APCLPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPN
SEX
+6 KILL APCLSORT,APCLSRT,APCLSORX,APCLFILE,APCLFIEL,APCLPRNT,APCLX,APCLTYPE,APCLFOUN,D0,J,K,L,APCLPRNM,APCLTEST,APCLSEAT,APCLLHDR,APCLFRST
+7 DO EN^XBVK("APCL")
+8 QUIT
V ;GETS DATA HITS
+1 SET APCLCNT=0
+2 ;get readable sort value
+3 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 KILL APCLFRST
+8 SET APCLVIEN=0
FOR
SET APCLVIEN=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,APCLVIEN))
IF APCLVIEN'=+APCLVIEN!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF APCLPTVS="V"
SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
SET DFN=$PIECE(APCLVREC,U,5)
DO PRINT
QUIT
+10 SET DFN=APCLVIEN
DO PRINT
+11 QUIT
End DoDot:1
+12 QUIT
PRINT ;
+1 KILL ^XTMP("APCLLINE",$JOB)
SET ^XTMP("APCLLINE",$JOB,1)=""
+2 KILL APCLDELD
+3 SET APCLPIEC=0
SET APCLLINE=1
SET APCLCNT=APCLCNT+1
+4 IF APCLPTVS="V"
SET APCLDELD(1,"S")=DFN
SET APCLDELD(2,"S")=APCLVIEN
SET APCLPIEC=2
+5 IF APCLPTVS="P"
SET APCLDELD(1,"S")=DFN
SET APCLPIEC=1
+6 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
+7 SET APCLPIEC=APCLPIEC+1
+8 IF '$PIECE(^APCLVSTS(APCLCRIT,0),U,8)
DO SINGLE
QUIT
+9 DO MULT
+10 QUIT
End DoDot:1
+11 KILL APCLDELP
+12 FOR X=1:1:APCLLINE
Begin DoDot:1
+13 SET APCLCNT=APCLCNT+1
+14 FOR P=1:1:APCLPIEC
Begin DoDot:2
+15 SET V=$ORDER(APCLDELD(P,""))
+16 IF V="S"
SET D=APCLDELD(P,V)
SET $PIECE(APCLDELP(APCLCNT),U,P)=D
+17 IF V="M"
SET D=$SELECT($PIECE(APCLDELD(P,V),"|",X)]"":$PIECE(APCLDELD(P,V),"|",X),1:"--")
SET $PIECE(APCLDELP(APCLCNT),U,P)=D
End DoDot:2
End DoDot:1
+18 SET X=0
FOR
SET X=$ORDER(APCLDELP(X))
IF X'=+X
QUIT
WRITE APCLDELP(X),!
+19 QUIT
SINGLE ;process single valued item
+1 KILL APCLPRNT
+2 SET APCLX=0
+3 IF $DATA(^APCLVSTS(APCLCRIT,3))
XECUTE ^(3)
+4 IF APCLPRNT=""
SET APCLPRNT="--"
+5 SET APCLDELD(APCLPIEC,"S")=APCLPRNT
+6 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 SET X=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET Z=$GET(APCLPRNM(X,"I"))
IF Z=""
KILL APCLPRNM(X)
QUIT
+9 IF '$DATA(^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Z))
KILL APCLPRNM(X)
End DoDot:2
End DoDot:1
+10 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)
+11 IF C>APCLLINE
SET APCLLINE=C
+12 KILL APCLPRNM
SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET APCLPRNM(X)=Y(X)
+13 IF '$DATA(APCLPRNM)
SET APCLPRNT="--"
Begin DoDot:1
+14 SET APCLDELD(APCLPIEC,"M")=APCLPRNT
End DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(APCLPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+16 SET $PIECE(APCLDELD(APCLPIEC,"M"),"|",X)=APCLPRNM(X)
End DoDot:1
+17 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
OPEN ;write flat file from global
+1 ;if screen selected do screen
+2 ;USE GS FROM GPRA TO OPEN AND WRITE FILE
+3 ;I APCLDELT="S" D SCREEN Q
+4 SET Y=$$OPEN^%ZISH(APCLHDIR,APCLDELF,"W")
+5 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file to write out DELIMITED data. Notify programmer."
QUIT
+6 USE IO
+7 QUIT
