- 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
- ;
- APCLCP81 ; IHS/CMI/LAB - APC report - process ; 11 Apr 2013 10:34 AM
- +1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
- +2 SET APCLBT=$HOROLOG
- SET APCLJOB=$JOB
- +3 DO XTMP^APCLOSUT("APCLCP8","PCC ACTIVITY REPORT")
- +4 SET APCLNN=APCLBIN
- SET APCLA=""
- FOR I=1:1
- SET APCLX=$PIECE(APCLNN,";",I)
- IF APCLX=""
- QUIT
- DO SETA
- +5 SET APCLDOBS=APCLA
- V ; Run by visit date
- +1 SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLSD))
- IF APCLODAT=""
- SET APCLET=$HOROLOG
- QUIT
- +2 SET APCLODAT=APCLSD_".9999"
- FOR
- SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
- IF APCLODAT=""!((APCLODAT\1)>APCLED)
- QUIT
- DO V1
- +3 SET APCLET=$HOROLOG
- +4 QUIT
- V1 ;
- +1 SET APCLVDFN=0
- FOR
- SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
- IF APCLVDFN'=+APCLVDFN
- QUIT
- IF $DATA(^AUPNVSIT(APCLVDFN,0))
- SET APCLVREC=^(0)
- DO PROC
- DO EOJ
- +2 QUIT
- PROC ;
- +1 KILL APCLSKIP
- +2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
- QUIT
- +3 IF '$PIECE(APCLVREC,U,9)
- QUIT
- +4 IF $PIECE(APCLVREC,U,11)
- QUIT
- +5 IF "DXECH"[$PIECE(APCLVREC,U,7)
- QUIT
- +6 IF "V"[$PIECE(APCLVREC,U,3)
- QUIT
- +7 IF $DATA(APCLLOC)
- IF $PIECE(APCLVREC,U,6)=""
- QUIT
- IF '$DATA(APCLLOC($PIECE(APCLVREC,U,6)))
- QUIT
- +8 IF $DATA(APCLCLN)
- IF $PIECE(APCLVREC,U,8)=""
- QUIT
- IF '$DATA(APCLCLN($PIECE(APCLVREC,U,8)))
- QUIT
- +9 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
- QUIT
- +10 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
- QUIT
- +11 SET (APCL1,APCL2)=0
- FOR L=0:0
- SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
- IF APCL2=""
- QUIT
- IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"
- SET APCL1=APCL1+1
- +12 IF APCL1=0
- QUIT
- +13 IF APCL1>1
- QUIT
- +14 SET APCLVLOC=$PIECE(APCLVREC,U,6)
- +15 SET APCLSEX=$PIECE(^DPT($PIECE(APCLVREC,U,5),0),U,2)
- +16 SET APCLFOUN=0
- DO PROC2
- +17 IF 'APCLFOUN
- QUIT
- +18 DO SET
- +19 QUIT
- EOJ KILL APCLVLOC,APCLVREC,APCLSKIP,APCL1,APCL2,APCLX,APCLY,APCLPRIM,APCLSEX,APCLDISC,APCLAGE,APCLVTM,APCLVTT
- +1 QUIT
- +2 ;
- +3 ;
- PROC2 ;
- +1 SET APCLX=0
- FOR
- SET APCLX=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLX))
- IF APCLX'=+APCLX!(APCLFOUN)
- QUIT
- SET APCLCHN=APCLX
- Begin DoDot:1
- +2 SET APCLAP=$PIECE(^AUPNVPRV(APCLX,0),U)
- +3 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
- SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
- IF '$DATA(^APCLACTG(APCLACTG,11,"AC",APCLDISC))
- QUIT
- SET APCLFOUN=1
- QUIT
- +4 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
- +5 IF APCLY=""
- QUIT
- +6 IF '$DATA(^DIC(7,APCLY,9999999))
- QUIT
- +7 IF '$DATA(^APCLACTG(APCLACTG,11,"AC",$PIECE(^DIC(7,APCLY,9999999),U)))
- QUIT
- +8 SET APCLFOUN=1
- +9 QUIT
- End DoDot:1
- +10 QUIT
- SET ;
- +1 SET APCLAGE=""
- DO GETAGE
- +2 IF 'APCLAGE
- QUIT
- +3 SET ^("TOTAL")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"TOTAL")):^("TOTAL")+1,1:1)
- +4 IF $PIECE(^AUPNVPRV(APCLCHN,0),U,4)="P"
- SET ^("PRIM")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"PRIM")):^("PRIM")+1,1:1)
- +5 IF $PIECE(^AUPNVPRV(APCLCHN,0),U,4)'="P"
- SET ^("SEC")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"SEC")):^("SEC")+1,1:1)
- +6 IF '$DATA(^AUPNVTM("AD",APCLVDFN))
- SET ^("NOACT")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,"NOACT")):^("NOACT")+1,1:1)
- QUIT
- +7 SET APCLVTM=$ORDER(^AUPNVTM("AD",APCLVDFN,""))
- SET APCLVACT=$PIECE(^AUPNVTM(APCLVTM,0),U)
- SET APCLVTT=$PIECE(^AUPNVTM(APCLVTM,0),U,4)
- +8 SET ^("ACT")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"ACT")):^("ACT")+APCLVACT,1:APCLVACT)
- +9 IF APCLVTT
- SET ^("TT")=$SELECT($DATA(^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX",APCLSEX,APCLAGE,"TT")):^("TT")+APCLVTT,1:APCLVTT)
- +10 QUIT
- GETAGE ;
- +1 SET APCLDOB=$PIECE(^DPT($PIECE(APCLVREC,U,5),0),U,3)
- IF APCLDOB=""
- QUIT
- ATT ;
- +1 ;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
- +2 SET APCLZ=$$AGE^AUPNPAT($PIECE(APCLVREC,U,5),$PIECE($PIECE(APCLVREC,U),"."))
- +3 FOR I=1:1
- SET APCLNN=$PIECE(APCLBIN,";",I)
- IF APCLNN=""
- QUIT
- SET APCLX=$PIECE(APCLNN,"-")
- SET APCLY=$PIECE(APCLNN,"-",2)
- IF APCLZ'<APCLX
- IF APCLZ'>APCLY
- SET APCLAGE=I
- QUIT
- +4 QUIT
- +5 ;
- SETA SET APCLY=$PIECE(APCLX,"-")
- SET APCLZ=$PIECE(APCLX,"-",2)
- +1 IF APCLA]""
- SET APCLA=APCLA_";"
- +2 SET APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_"-"_(DT-(APCLY*10000))
- +3 SET ^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","M",I,"TOTAL")=0
- SET ^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","F",I,"TOTAL")=0
- SET ^XTMP("APCLCP8",APCLJOB,APCLBT,"SEX","U",I,"TOTAL")=0
- +4 QUIT
- +5 ;
