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

APCLCP81.m

Go to the documentation of this file.
APCLCP81 ; IHS/CMI/LAB - APC report - process ; 11 Apr 2013  10:34 AM
 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
 S APCLBT=$H,APCLJOB=$J
 D XTMP^APCLOSUT("APCLCP8","PCC ACTIVITY REPORT")
 S APCLNN=APCLBIN,APCLA="" F I=1:1 S APCLX=$P(APCLNN,";",I) Q:APCLX=""  D SETA
 S APCLDOBS=APCLA
V ; Run by visit date
 S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) I APCLODAT="" S APCLET=$H Q
 S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1
 S APCLET=$H
 Q
V1 ;
 S APCLVDFN=0 F  S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
 Q
PROC ;
 K APCLSKIP
 Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
 Q:'$P(APCLVREC,U,9)
 Q:$P(APCLVREC,U,11)
 Q:"DXECH"[$P(APCLVREC,U,7)
 Q:"V"[$P(APCLVREC,U,3)
 I $D(APCLLOC) Q:$P(APCLVREC,U,6)=""  I '$D(APCLLOC($P(APCLVREC,U,6))) Q
 I $D(APCLCLN) Q:$P(APCLVREC,U,8)=""  I '$D(APCLCLN($P(APCLVREC,U,8))) Q
 Q:'$D(^AUPNVPOV("AD",APCLVDFN))
 Q:'$D(^AUPNVPRV("AD",APCLVDFN))
 S (APCL1,APCL2)=0 F L=0:0 S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1
 I APCL1=0 Q
 I APCL1>1 Q
 S APCLVLOC=$P(APCLVREC,U,6)
 S APCLSEX=$P(^DPT($P(APCLVREC,U,5),0),U,2)
 S APCLFOUN=0 D PROC2
 Q:'APCLFOUN
 D SET
 Q
EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,APCLSEX,APCLDISC,APCLAGE,APCLVTM,APCLVTT
 Q
 ;
 ;
PROC2 ;
 S APCLX=0 F  S APCLX=$O(^AUPNVPRV("AD",APCLVDFN,APCLX)) Q:APCLX'=+APCLX!(APCLFOUN)  S APCLCHN=APCLX D
 . S APCLAP=$P(^AUPNVPRV(APCLX,0),U)
 . I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)  Q:'$D(^APCLACTG(APCLACTG,11,"AC",APCLDISC))  S APCLFOUN=1 Q
 . S APCLY=$P(^DIC(6,APCLAP,0),U,4)
 . I APCLY="" Q
 . I '$D(^DIC(7,APCLY,9999999)) Q
 . Q:'$D(^APCLACTG(APCLACTG,11,"AC",$P(^DIC(7,APCLY,9999999),U)))
 . S APCLFOUN=1
 . Q
 Q
SET ;
 S APCLAGE="" D GETAGE
 Q:'APCLAGE
 S ^("TOTAL")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"TOTAL")):^("TOTAL")+1,1:1)
 I $P(^AUPNVPRV(APCLCHN,0),U,4)="P" S ^("PRIM")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"PRIM")):^("PRIM")+1,1:1)
 I $P(^AUPNVPRV(APCLCHN,0),U,4)'="P" S ^("SEC")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"SEC")):^("SEC")+1,1:1)
 I '$D(^AUPNVTM("AD",APCLVDFN)) S ^("NOACT")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,"NOACT")):^("NOACT")+1,1:1) Q
 S APCLVTM=$O(^AUPNVTM("AD",APCLVDFN,"")),APCLVACT=$P(^AUPNVTM(APCLVTM,0),U),APCLVTT=$P(^AUPNVTM(APCLVTM,0),U,4)
  S ^("ACT")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)
  I APCLVTT S ^("TT")=$S($D(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"TT")):^("TT")+APCLVTT,1:APCLVTT)
 Q
GETAGE ;
 S APCLDOB=$P(^DPT($P(APCLVREC,U,5),0),U,3) Q:APCLDOB=""
ATT ;
 ;F I=1:1 S APCLNN=$P(APCLA,";",I) Q:APCLNN=""  S APCLX=$P(APCLNN,"-"),APCLY=$P(APCLNN,"-",2) I APCLDOB'<APCLX,APCLDOB'>APCLY  S APCLAGE=I Q
 S APCLZ=$$AGE^AUPNPAT($P(APCLVREC,U,5),$P($P(APCLVREC,U),"."))
 F I=1:1 S APCLNN=$P(APCLBIN,";",I) Q:APCLNN=""  S APCLX=$P(APCLNN,"-"),APCLY=$P(APCLNN,"-",2) I APCLZ'<APCLX,APCLZ'>APCLY  S APCLAGE=I Q
 Q
 ;
SETA S APCLY=$P(APCLX,"-"),APCLZ=$P(APCLX,"-",2)
 I APCLA]"" S APCLA=APCLA_";"
 S APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_"-"_(DT-(APCLY*10000))
 S ^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","M",I,"TOTAL")=0,^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","F",I,"TOTAL")=0,^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","U",I,"TOTAL")=0
 Q
 ;