APCLCZP1 ; IHS/CMI/LAB - All visit report process ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;cmi/anch/maw 9/10/2007 code set versioning in DX
;
START ;
S APCLBT=$H
K ^XTMP("APCLCZP",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLCZ","PCC - ZIP CODE REPORT")
;
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
;
END ;
S APCLET=$H
D EOJ
Q
V1 ;
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
Q
PROC ;
K APCLSKIP
Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
Q:'$P(APCLVREC,U,9)
Q:$P(APCLVREC,U,11)
;Q:"EDXCIH"[$P(APCLVREC,U,7)
Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;lab/ohprd changed CV to C for VA use
S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
Q:'$D(^AUTTLOC(APCLVLOC))
Q:'$D(^DIC(4,APCLVLOC))
I APCLLOC]"",APCLLOC'=APCLVLOC Q
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
Q:'$D(^AUPNVPRV("AD",APCLVDFN))
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)
I APCL1=0 Q
I APCL1>1 Q
;S APCLDISC="" D CHKDISC
D @APCLPROC
;CODE TO GET ZIP CODE
S APCLCZP=$P($G(^DPT($P(APCLVREC,U,5),.11)),U,6) I APCLCZP="" S APCLCZP="NONE"
S ^(APCLCZP)=$S($D(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2,APCLCZP)):^(APCLCZP)+1,1:1)
Q
EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ
Q
;
CLIN ;
S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN="NO CLINIC ENTERED",APCLSRT2="99999" Q
CLIN1 S APCLSRT2=$P(^DIC(40.7,APCLCLIN,0),U,2),APCLCLIN=$P(^DIC(40.7,APCLCLIN,0),U) I APCLSRT2="" S APCLSRT2="XX"
Q
;
SC ;
K ^UTILITY("DIQ1",$J)
K DIQ,DIC,DA,DR
S DIC="^AUPNVSIT(",DR=".07",DA=APCLVDFN,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ
S APCLCAT=^UTILITY("DIQ1",$J,9000010,APCLVDFN,.07,"E")
S APCLSRT2=$P(APCLVREC,U,7)
K ^UTILITY("DIQ1",$J)
Q
DATE ;
S APCLDATE=$P(APCLODAT,".")
S X=APCLDATE D H^%DTC S APCLSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I APCLSRT2="" S APCLSRT2="UNKNOWN"
Q
LOS ;
S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10)
Q
;
SETSEC ;
S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
Q:APCLSEC=""
Q:'$D(^DIC(16,APCLSEC,0))
S APCLZ=$P(^DIC(6,APCLSEC,0),U,4)
I APCLZ="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC1
Q:'$D(^DIC(7,APCLZ,9999999))
S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) I APCLSRT2="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC1
S APCLSRT2=$P(^DIC(7,APCLZ,0),U)
SETSEC1 S APCLSEC=$P(^DIC(16,APCLSEC,0),U)
S ^(APCLSRT2)=$S($D(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
APCLCZP1 ; IHS/CMI/LAB - All visit report process ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in DX
+4 ;
START ;
+1 SET APCLBT=$HOROLOG
+2 KILL ^XTMP("APCLCZP",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLCZ","PCC - ZIP CODE REPORT")
+4 ;
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 ;
END ;
+1 SET APCLET=$HOROLOG
+2 DO EOJ
+3 QUIT
V1 ;
+1 SET APCLVDFN=""
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
IF $DATA(^AUPNVSIT(APCLVDFN,0))
IF "AOS"[$PIECE(^(0),U,7)
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 ;Q:"EDXCIH"[$P(APCLVREC,U,7)
+6 ;lab/ohprd changed CV to C for VA use
IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLVREC,U,3)))
QUIT
+7 SET APCLVLOC=$PIECE(APCLVREC,U,6)
IF APCLVLOC=""
QUIT
+8 IF '$DATA(^AUTTLOC(APCLVLOC))
QUIT
+9 IF '$DATA(^DIC(4,APCLVLOC))
QUIT
+10 IF APCLLOC]""
IF APCLLOC'=APCLVLOC
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
+12 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
QUIT
+13 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)
+14 IF APCL1=0
QUIT
+15 IF APCL1>1
QUIT
+16 ;S APCLDISC="" D CHKDISC
+17 DO @APCLPROC
+18 ;CODE TO GET ZIP CODE
+19 SET APCLCZP=$PIECE($GET(^DPT($PIECE(APCLVREC,U,5),.11)),U,6)
IF APCLCZP=""
SET APCLCZP="NONE"
+20 SET ^(APCLCZP)=$SELECT($DATA(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2,APCLCZP)):^(APCLCZP)+1,1:1)
+21 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ
+1 QUIT
+2 ;
CLIN ;
+1 SET APCLCLIN=$PIECE(APCLVREC,U,8)
IF APCLCLIN=""
SET APCLCLIN="NO CLINIC ENTERED"
SET APCLSRT2="99999"
QUIT
CLIN1 SET APCLSRT2=$PIECE(^DIC(40.7,APCLCLIN,0),U,2)
SET APCLCLIN=$PIECE(^DIC(40.7,APCLCLIN,0),U)
IF APCLSRT2=""
SET APCLSRT2="XX"
+1 QUIT
+2 ;
SC ;
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 KILL DIQ,DIC,DA,DR
+3 SET DIC="^AUPNVSIT("
SET DR=".07"
SET DA=APCLVDFN
SET DIQ(0)="E"
DO EN^DIQ1
KILL DIC,DA,DR,DIQ
+4 SET APCLCAT=^UTILITY("DIQ1",$JOB,9000010,APCLVDFN,.07,"E")
+5 SET APCLSRT2=$PIECE(APCLVREC,U,7)
+6 KILL ^UTILITY("DIQ1",$JOB)
+7 QUIT
DATE ;
+1 SET APCLDATE=$PIECE(APCLODAT,".")
+2 SET X=APCLDATE
DO H^%DTC
SET APCLSRT2=$PIECE("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1)
IF APCLSRT2=""
SET APCLSRT2="UNKNOWN"
+3 QUIT
LOS ;
+1 SET APCLSRT2=$PIECE(^AUTTLOC(APCLVLOC,0),U,10)
+2 QUIT
+3 ;
SETSEC ;
+1 SET APCLSEC=$PIECE(^AUPNVPRV(APCL2,0),U)
+2 IF APCLSEC=""
QUIT
+3 IF '$DATA(^DIC(16,APCLSEC,0))
QUIT
+4 SET APCLZ=$PIECE(^DIC(6,APCLSEC,0),U,4)
+5 IF APCLZ=""
SET APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE"
GOTO SETSEC1
+6 IF '$DATA(^DIC(7,APCLZ,9999999))
QUIT
+7 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,9999999),U)
IF APCLSRT2=""
SET APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE"
GOTO SETSEC1
+8 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,0),U)
SETSEC1 SET APCLSEC=$PIECE(^DIC(16,APCLSEC,0),U)
+1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLCZP",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+2 QUIT
