- 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