Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLVLP8

APCLVLP8.m

Go to the documentation of this file.
  1. APCLVLP8 ; IHS/CMI/LAB - PRINT VISIT REPORT ;
  1. ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1. ;IHS/TUCSON/LAB - added killing of APCLPRNT to V subroutine 05/19/97
  1. ;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97
  1. DELIMIT ;EP - Set up header line, dash line
  1. S APCLFCNT=0
  1. K ^XTMP($J,"APCLFLAT") ;just in case
  1. K ^TMP($J,"APCLDELIMITED")
  1. S APCLDELC=0,APCLPIEC=0
  1. I APCLPTVS="V" S APCLHDR="PATIENT IEN"_U_"VISIT IEN",APCLPIEC=2
  1. I APCLPTVS="P" S APCLHDR="PATIENT IEN",APCLPIEC=1
  1. S X=0,APCLHEAD="" F S X=$O(^APCLVRPT(APCLRPT,12,X)) Q:X'=+X D
  1. .S APCLPIEC=APCLPIEC+1
  1. .S H=$P(^APCLVSTS($P(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6)
  1. .S $P(APCLHDR,U,APCLPIEC)=H
  1. .Q
  1. D COVPAGE^APCLVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
  1. PROC ;process printing of report
  1. I APCLDELT="F" D OPEN Q:Y=1
  1. W !,APCLHDR,!
  1. I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) W !,"NO DATA TO REPORT" G DONE
  1. S (APCLSRTV,APCLFRST)="" K APCLQUIT
  1. F S APCLSRTV=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV)) Q:APCLSRTV=""!($D(APCLQUIT)) D V
  1. DONE ;
  1. ;write out delimited file
  1. I APCLDELT="F" D ^%ZISC
  1. K ^XTMP("APCLVL",APCLJOB,APCLBT),^XTMP("APCLFLAT",$J),^TMP($J,"APCLDELIMITED")
  1. D DEL^APCLVL
  1. 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
  1. K APCLSORT,APCLSRT,APCLSORX,APCLFILE,APCLFIEL,APCLPRNT,APCLX,APCLTYPE,APCLFOUN,D0,J,K,L,APCLPRNM,APCLTEST,APCLSEAT,APCLLHDR,APCLFRST
  1. D EN^XBVK("APCL")
  1. Q
  1. V ;GETS DATA HITS
  1. S APCLCNT=0
  1. ;get readable sort value
  1. K APCLPRNT
  1. S APCLSRTR="",APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,0)) I APCLVIEN]"" S APCLCRIT=APCLSORT D
  1. .I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT
  1. .I APCLPTVS="P" S DFN=APCLVIEN X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT
  1. K APCLFRST
  1. S APCLVIEN=0 F S APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN!($D(APCLQUIT)) D
  1. .I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) D PRINT Q
  1. .S DFN=APCLVIEN D PRINT
  1. .Q
  1. Q
  1. PRINT ;
  1. K ^XTMP("APCLLINE",$J) S ^XTMP("APCLLINE",$J,1)=""
  1. K APCLDELD
  1. S APCLPIEC=0,APCLLINE=1,APCLCNT=APCLCNT+1
  1. I APCLPTVS="V" S APCLDELD(1,"S")=DFN,APCLDELD(2,"S")=APCLVIEN,APCLPIEC=2
  1. I APCLPTVS="P" S APCLDELD(1,"S")=DFN,APCLPIEC=1
  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
  1. .S APCLPIEC=APCLPIEC+1
  1. .I '$P(^APCLVSTS(APCLCRIT,0),U,8) D SINGLE Q
  1. .D MULT
  1. .Q
  1. K APCLDELP
  1. F X=1:1:APCLLINE D
  1. .S APCLCNT=APCLCNT+1
  1. .F P=1:1:APCLPIEC D
  1. ..S V=$O(APCLDELD(P,""))
  1. ..I V="S" S D=APCLDELD(P,V),$P(APCLDELP(APCLCNT),U,P)=D
  1. ..I V="M" S D=$S($P(APCLDELD(P,V),"|",X)]"":$P(APCLDELD(P,V),"|",X),1:"--"),$P(APCLDELP(APCLCNT),U,P)=D
  1. S X=0 F S X=$O(APCLDELP(X)) Q:X'=+X W APCLDELP(X),!
  1. Q
  1. SINGLE ;process single valued item
  1. K APCLPRNT
  1. S APCLX=0
  1. X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
  1. I APCLPRNT="" S APCLPRNT="--"
  1. S APCLDELD(APCLPIEC,"S")=APCLPRNT
  1. Q
  1. MULT ;
  1. K APCLPRNT,APCLPRNM,APCLY S (APCLX,APCLPCNT)=0
  1. X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
  1. ;if 13th, then $o through delete bad ones and then reorder/number
  1. ;new logic here to screen if user wants to screen
  1. I $P(^APCLVRPT(APCLRPT,12,APCLI,0),U,3) D
  1. .;does this one match selected ones?
  1. .S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D
  1. ..S Z=$G(APCLPRNM(X,"I")) I Z="" K APCLPRNM(X) Q
  1. ..I '$D(^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Z)) K APCLPRNM(X)
  1. K Y S (X,C)=0 F S X=$O(APCLPRNM(X)) Q:X'=+X S C=C+1,Y(C)=APCLPRNM(X)
  1. I C>APCLLINE S APCLLINE=C
  1. K APCLPRNM S X=0 F S X=$O(Y(X)) Q:X'=+X S APCLPRNM(X)=Y(X)
  1. I '$D(APCLPRNM) S APCLPRNT="--" D
  1. .S APCLDELD(APCLPIEC,"M")=APCLPRNT
  1. S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D
  1. .S $P(APCLDELD(APCLPIEC,"M"),"|",X)=APCLPRNM(X)
  1. Q
  1. DIQ ;
  1. K APCLPRNT,APCLFILE,APCLFIEL
  1. S APCLFILE=$P($P(^APCLVSTS(APCLCRIT,0),U,4),","),APCLFIEL=$P($P(^(0),U,4),",",2)
  1. S DIQ(0)="EN",DIQ="APCLPRNT(",DIC=APCLFILE,DR=APCLFIEL D EN^DIQ1 K DIC,DR,DIQ
  1. I '$D(APCLPRNT(APCLFILE,DA,APCLFIEL,"E")) S APCLPRNT(APCLFILE,DA,APCLFIEL,"E")="--"
  1. S APCLPRNT=APCLPRNT(APCLFILE,DA,APCLFIEL,"E")
  1. Q
  1. OPEN ;write flat file from global
  1. ;if screen selected do screen
  1. ;USE GS FROM GPRA TO OPEN AND WRITE FILE
  1. ;I APCLDELT="S" D SCREEN Q
  1. S Y=$$OPEN^%ZISH(APCLHDIR,APCLDELF,"W")
  1. I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file to write out DELIMITED data. Notify programmer." Q
  1. U IO
  1. Q