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

APCLCZP1.m

Go to the documentation of this file. 
  1. APCLCZP1 ; IHS/CMI/LAB - All visit report process ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;cmi/anch/maw 9/10/2007 code set versioning in DX
  1.  ;
  1. START ;
  1.  S APCLBT=$H
  1.  K ^XTMP("APCLCZP",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLCZ","PCC - ZIP CODE REPORT")
  1.  ;
  1. V ; Run by visit date
  1.  S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) I APCLODAT="" S APCLET=$H Q
  1.  S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1
  1.  ;
  1. END ;
  1.  S APCLET=$H
  1.  D EOJ
  1.  Q
  1. V1 ;
  1.  S APCLVDFN="" F  S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)),"AOS"[$P(^(0),U,7) S APCLVREC=^(0) D PROC,EOJ
  1.  Q
  1. PROC ;
  1.  K APCLSKIP
  1.  Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
  1.  Q:'$P(APCLVREC,U,9)
  1.  Q:$P(APCLVREC,U,11)
  1.  ;Q:"EDXCIH"[$P(APCLVREC,U,7)
  1.  Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))  ;lab/ohprd changed CV to C for VA use
  1.  S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
  1.  Q:'$D(^AUTTLOC(APCLVLOC))
  1.  Q:'$D(^DIC(4,APCLVLOC))
  1.  I APCLLOC]"",APCLLOC'=APCLVLOC Q
  1.  Q:'$D(^AUPNVPOV("AD",APCLVDFN))
  1.  Q:'$D(^AUPNVPRV("AD",APCLVDFN))
  1.  S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1,APCLAP=$P(^(0),U)
  1.  I APCL1=0 Q
  1.  I APCL1>1 Q
  1.  ;S APCLDISC="" D CHKDISC
  1.  D @APCLPROC
  1.  ;CODE TO GET ZIP CODE
  1.  S APCLCZP=$P($G(^DPT($P(APCLVREC,U,5),.11)),U,6) I APCLCZP="" S APCLCZP="NONE"
  1.  S ^(APCLCZP)=$S($D(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2,APCLCZP)):^(APCLCZP)+1,1:1)
  1.  Q
  1. EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ
  1.  Q
  1.  ;
  1. CLIN ;
  1.  S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN="NO CLINIC ENTERED",APCLSRT2="99999" Q
  1. CLIN1 S APCLSRT2=$P(^DIC(40.7,APCLCLIN,0),U,2),APCLCLIN=$P(^DIC(40.7,APCLCLIN,0),U) I APCLSRT2="" S APCLSRT2="XX"
  1.  Q
  1.  ;
  1. SC ;
  1.  K ^UTILITY("DIQ1",$J)
  1.  K DIQ,DIC,DA,DR
  1.  S DIC="^AUPNVSIT(",DR=".07",DA=APCLVDFN,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ
  1.  S APCLCAT=^UTILITY("DIQ1",$J,9000010,APCLVDFN,.07,"E")
  1.  S APCLSRT2=$P(APCLVREC,U,7)
  1.  K ^UTILITY("DIQ1",$J)
  1.  Q
  1. DATE ;
  1.  S APCLDATE=$P(APCLODAT,".")
  1.  S X=APCLDATE D H^%DTC S APCLSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I APCLSRT2="" S APCLSRT2="UNKNOWN"
  1.  Q
  1. LOS ;
  1.  S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10)
  1.  Q
  1.  ;
  1. SETSEC ;
  1.  S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:APCLSEC=""
  1.  Q:'$D(^DIC(16,APCLSEC,0))
  1.  S APCLZ=$P(^DIC(6,APCLSEC,0),U,4)
  1.  I APCLZ="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC1
  1.  Q:'$D(^DIC(7,APCLZ,9999999))
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) I APCLSRT2="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC1
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,0),U)
  1. SETSEC1 S APCLSEC=$P(^DIC(16,APCLSEC,0),U)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q