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

APCLVLP.m

Go to the documentation of this file. 
  1. APCLVLP ; 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. START ;EP - Set up header line, dash line
  1.  I APCLCTYP="L" D DELIMIT^APCLVLP8 Q
  1.  S APCLFCNT=0
  1.  K ^XTMP($J,"APCLFLAT") ;just in case
  1.  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
  1.  .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_" "
  1.  .Q
  1.  S APCLDASH="",$P(APCLDASH,"-",APCLTCW)="-"
  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 APCLCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done
  1.  I APCLCTYP="C" G DONE ;--- if doing a template, that's already done so goto done
  1.  I APCLCTYP="P" G DONE ; -- template
  1.  S APCLPG=0 I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) 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.  G:$D(APCLQUIT) DONE
  1.  I APCLCTYP="F" D  G DONE
  1.  .D WRITEF
  1.  .W:'$D(ZTQUEUED) !!,"Flat file ",APCLOUTF," has been created."
  1.  .W:'$D(ZTQUEUED) !,"Total number of visits counted in selection process: ",APCLRCNT
  1.  .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
  1.  .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."
  1.  .W:'$D(ZTQUEUED) !,"Errors that could occur would be similar to errors seen on the PCC Visit",!,"review reports.",!
  1.  I $Y>(IOSL-4) D HEAD G:$D(APCLQUIT) DONE
  1.  I $D(APCLRCNT) W !!!,"Total ",$S(APCLPTVS="P":"Patients",1:"Visits"),":  ",APCLRCNT
  1.  I $G(APCLPTVS)="V" W !,"Total Patients:  ",APCLPTCT
  1. DONE ;
  1.  D DONE^APCLVLP2
  1.  Q
  1. V ;GETS DATA HITS
  1.  S APCLSCNT=0
  1.  ;get readable sort value
  1.  K APCLPRNT ;IHS/TUCSON/LAB - added this kill to prevent wrong value patch 1 05/19/97
  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.  I $G(APCLSPAG)!($D(APCLFRST)) D HEAD Q:$D(APCLQUIT)
  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:$D(APCLQUIT)
  1.  I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT)
  1.  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)
  1.  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)"
  1.  I APCLCTYP="S",(APCLPTVS="P") W !,?10,$E(APCLSRTR,1,30),?45,$J(APCLSCNT,8)
  1.  Q
  1. PRINT ;
  1.  I APCLCTYP="F" D FLAT Q
  1.  S APCLSCNT=APCLSCNT+1 Q:APCLCTYP="S"
  1.  K ^XTMP("APCLLINE",$J) S ^XTMP("APCLLINE",$J,1)=""
  1.  I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
  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.  .I '$P(^APCLVSTS(APCLCRIT,0),U,8) D SINGLE Q
  1.  .D MULT
  1.  .Q
  1.  S APCLX=0 F  S APCLX=$O(^XTMP("APCLLINE",$J,APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT))  D
  1.  .I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
  1.  .W !,^XTMP("APCLLINE",$J,APCLX)
  1.  Q
  1. SINGLE ;process single valued item
  1.  K APCLPRNT
  1.  S APCLX=0
  1.  X:$D(^APCLVSTS(APCLCRIT,3)) ^(3)
  1.  S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D
  1.  .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)_" "
  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)_" "
  1.  Q
  1. LABLOINC ;
  1.  S X=0 F  S X=$O(APCLPRNM(X)) Q:X'=+X  S Y=$G(APCLPRNM(X,"I")) D
  1.  .Q:Y=""
  1.  .Q:'$D(^AUPNVLAB(Y,0))
  1.  .S Z=$P(^AUPNVLAB(Y,0),U)
  1.  .Q:$D(APCLLABT("LAB",Z))
  1.  .S J=$P($G(^AUPNVLAB(Y,11)),U,13)
  1.  .I J="" K APCLPRNM(X) Q
  1.  .I $$LOINC^APCLVLU1(J) Q
  1.  .K APCLPRNM(X)
  1.  .Q
  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.  .I $P(^APCLVSTS(APCLCRIT,0),U,14) D LABLOINC G NEXT
  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. NEXT ; 
  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.  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 APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D
  1.  ..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)_" "
  1.  S X=0 F  S X=$O(APCLPRNM(X)) Q:X'=+X  D
  1.  .I X=1 D  Q
  1.  ..S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(1),1,APCLLENG) D
  1.  ...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)_" "
  1.  .S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(X),1,APCLLENG) D
  1.  ..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))=""
  1.  ..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)_" "
  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)_" "
  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. FLAT ;
  1.  ;IHS/TUCSON/LAB - modified this subroutine to add a third record patch 1 05/27/97
  1.  K APCLX1,APCLX2,APCLX3 ;IHS/TUCSON/LAB - added kill of APCLX3
  1.  S APCLX1=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 1")
  1.  Q:APCLX1=""
  1.  Q:APCLX1=-1
  1.  S APCLX2=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 2")
  1.  G:APCLX2="" FLATX
  1.  G:APCLX2=-1 FLATX
  1.  S APCLX3=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 3")
  1.  Q:APCLX3=""
  1.  G:APCLX3=-1 FLATX
  1.  S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX1
  1.  S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX2
  1.  S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX3
  1. FLATX K APCLX1,APCLX2,APCLV0,APCLX3
  1.  Q
  1.  D HEAD^APCLVLP2
  1.  Q
  1. WRITEF ;write flat file from global
  1.  D WRITEF^APCLVLP2
  1.  Q