APCLAA1 ; IHS/CMI/LAB - Process APC 1A report ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;CMI/TUCSON/LAB - patch 3 FY fix
START ;
S APCLBT=$H,APCLJOB=$J
K ^XTMP("APCLAA",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLAA","PCC VISITS BY PROV DISC")
;beginning Y2K fix
;S X1=APCLFY,X2=-1 D C^%DTC S APCLSD=X S X1=APCLFY,X2=365 D C^%DTC S APCLFYE=$E(X,1,3)_"0930" ;Y2000
;end Y2K
V ; Run by visit date
S APCLGRAN=0
S APCLSD=APCLSD_".9999" F S APCLSD=$O(^AUPNVSIT("B",APCLSD)) Q:APCLSD=""!((APCLSD\1)>APCLFYE) D V1
;
XIT ;
D EOJ
S APCLET=$H
Q
V1 ;
S APCLVDFN="" F S APCLVDFN=$O(^AUPNVSIT("B",APCLSD,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
Q
PROC ;
K APCLSKIP
Q:'$P(APCLVREC,U,9)
Q:$P(APCLVREC,U,11)
Q:"EHI"[$P(APCLVREC,U,7)
Q:"CV"[$P(APCLVREC,U,3)
I APCLLOC]"",APCLLOC'=$P(APCLVREC,U,6) Q
S DFN=$P(APCLVREC,U,5)
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO)) ;IHS/CMI/LAB - all demo patients
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
Q:'$D(^AUPNVPRV("AD",APCLVDFN))
S APCLVLOC=$P(APCLVREC,U,6)
Q:'$D(^DIC(4,APCLVLOC))
Q:'$D(^AUTTLOC(APCLVLOC))
;
PROC1 ;
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)
Q:APCL1=0
Q:APCL1>1
S APCLDISC="" D CHKDISC
Q:$D(APCLSKIP)
S APCLMOS=+$E(APCLSD,4,5)
S ^(APCLMOS)=$S($D(^XTMP("APCLAA",APCLJOB,APCLBT,"MODISC",APCLDPTR,APCLMOS)):^(APCLMOS)+1,1:1)
S ^(APCLDPTR)=$S($D(^XTMP("APCLAA",APCLJOB,APCLBT,"DISCTOT",APCLDPTR)):^(APCLDPTR)+1,1:1)
S APCLGRAN=APCLGRAN+1
Q
EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN
K X,X1,X2
Q
;
CHKDISC ;
I $P(^DD(9000010.06,.01,0),U,2)[200 D CHKDISC2 Q ;FILE 200 CONV
I '$D(^DIC(6,APCLAP)) S APCLSKIP=1 Q
S APCLDPTR=$P(^DIC(6,APCLAP,0),U,4)
I APCLDPTR="" S APCLDISC="??",APCLDPTR="??" Q
I '$D(^DIC(7,APCLDPTR,9999999)) S APCLDISC="??" Q
S APCLDISC=$P(^DIC(7,APCLDPTR,9999999),U) I APCLDISC="" S APCLSKIP=1 Q
S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
Q
;
;
CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN"!(APCLDISC="") S APCLSKIP=1 Q
S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
Q
;
APCLAA1 ; IHS/CMI/LAB - Process APC 1A report ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;CMI/TUCSON/LAB - patch 3 FY fix
START ;
+1 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
+2 KILL ^XTMP("APCLAA",APCLJOB,APCLBT)
+3 DO XTMP^APCLOSUT("APCLAA","PCC VISITS BY PROV DISC")
+4 ;beginning Y2K fix
+5 ;S X1=APCLFY,X2=-1 D C^%DTC S APCLSD=X S X1=APCLFY,X2=365 D C^%DTC S APCLFYE=$E(X,1,3)_"0930" ;Y2000
+6 ;end Y2K
V ; Run by visit date
+1 SET APCLGRAN=0
+2 SET APCLSD=APCLSD_".9999"
FOR
SET APCLSD=$ORDER(^AUPNVSIT("B",APCLSD))
IF APCLSD=""!((APCLSD\1)>APCLFYE)
QUIT
DO V1
+3 ;
XIT ;
+1 DO EOJ
+2 SET APCLET=$HOROLOG
+3 QUIT
V1 ;
+1 SET APCLVDFN=""
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLSD,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 '$PIECE(APCLVREC,U,9)
QUIT
+3 IF $PIECE(APCLVREC,U,11)
QUIT
+4 IF "EHI"[$PIECE(APCLVREC,U,7)
QUIT
+5 IF "CV"[$PIECE(APCLVREC,U,3)
QUIT
+6 IF APCLLOC]""
IF APCLLOC'=$PIECE(APCLVREC,U,6)
QUIT
+7 SET DFN=$PIECE(APCLVREC,U,5)
+8 ;IHS/CMI/LAB - all demo patients
IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+9 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
QUIT
+11 SET APCLVLOC=$PIECE(APCLVREC,U,6)
+12 IF '$DATA(^DIC(4,APCLVLOC))
QUIT
+13 IF '$DATA(^AUTTLOC(APCLVLOC))
QUIT
+14 ;
PROC1 ;
+1 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
IF APCL2=""
QUIT
IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"
SET APCL1=APCL1+1
SET APCLAP=$PIECE(^(0),U)
+2 IF APCL1=0
QUIT
+3 IF APCL1>1
QUIT
+4 SET APCLDISC=""
DO CHKDISC
+5 IF $DATA(APCLSKIP)
QUIT
+6 SET APCLMOS=+$EXTRACT(APCLSD,4,5)
+7 SET ^(APCLMOS)=$SELECT($DATA(^XTMP("APCLAA",APCLJOB,APCLBT,"MODISC",APCLDPTR,APCLMOS)):^(APCLMOS)+1,1:1)
+8 SET ^(APCLDPTR)=$SELECT($DATA(^XTMP("APCLAA",APCLJOB,APCLBT,"DISCTOT",APCLDPTR)):^(APCLDPTR)+1,1:1)
+9 SET APCLGRAN=APCLGRAN+1
+10 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN
+1 KILL X,X1,X2
+2 QUIT
+3 ;
CHKDISC ;
+1 ;FILE 200 CONV
IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
DO CHKDISC2
QUIT
+2 IF '$DATA(^DIC(6,APCLAP))
SET APCLSKIP=1
QUIT
+3 SET APCLDPTR=$PIECE(^DIC(6,APCLAP,0),U,4)
+4 IF APCLDPTR=""
SET APCLDISC="??"
SET APCLDPTR="??"
QUIT
+5 IF '$DATA(^DIC(7,APCLDPTR,9999999))
SET APCLDISC="??"
QUIT
+6 SET APCLDISC=$PIECE(^DIC(7,APCLDPTR,9999999),U)
IF APCLDISC=""
SET APCLSKIP=1
QUIT
+7 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
+8 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
SET APCLSKIP=1
+9 QUIT
+10 ;
+11 ;
CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
+1 IF '$DATA(^VA(200,APCLAP))
SET APCLSKIP=1
QUIT
+2 SET APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I")
IF APCLDPTR=""!(APCLDPTR="UNKNOWN")
SET APCLDISC="???"
QUIT
+3 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
IF APCLDISC="UNKNOWN"!(APCLDISC="")
SET APCLSKIP=1
QUIT
+4 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
+5 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
SET APCLSKIP=1
+6 QUIT
+7 ;
