APCLYV31 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/12/2007 code set versioning PV1,PV2,PRC
;
DGZCALL ;EP for DGZCALLS routine
Q:'$D(APCLBD)!('$D(APCLED))
I '$D(APCLCL) D
. K DIC S DIC=40.7,DIC(0)="M",X=44 D ^DIC
. I Y=-1 W !!,*7,"DAY SURGERY CODE 44 NOT IN CLINIC STOP FILE!",!! Q
. S APCLCL=+Y
S:'$D(APCLICD) APCLICD=1
S:'$D(APCLBICD) APCLBICD=""
S:'$D(APCLEICD) APCLEICD=""
CALC ;find visits by date then store by patient name
;
S APCLJOB=$J,APCLBT=$H
D XTMP^APCLOSUT("APCLYV3","PCC LISTING OF CLINIC VISITS")
S APCLVDT=APCLBD-.0001
VST S APCLVDT=$O(^AUPNVSIT("B",APCLVDT))
G NEXT:APCLVDT="",NEXT:APCLVDT>(APCLED+.2359) S APCLVDFN=0
VST1 S APCLVDFN=$O(^AUPNVSIT("B",APCLVDT,APCLVDFN)) G VST:APCLVDFN=""
;
G VST1:'$D(^AUPNVSIT(APCLVDFN,0)) S APCLSTR=^(0)
G VST1:$P(APCLSTR,"^",11) ;screen out deleted visits
G VST1:$$DEMO^APCLUTL($P(APCLSTR,U,5),$G(APCLDEMO))
I APCLLOC]"",$P(APCLSTR,U,6)'=APCLLOC G VST1
G VST1:"HDXEIO"[$P(APCLSTR,"^",7)
G:$D(^APCLCNTL(4,11,"B",$P(APCLSTR,"^",3))) VST1
I APCLPROV]"" S APCLFOUN=0 D PROV G:'APCLFOUN VST1
I +APCLCL G VST1:$P(APCLSTR,"^",8)'=APCLCL
I APCLCL="N" G VST1:$P(APCLSTR,"^",8)'=""
S APCLCLX=$S(APCLCL=+APCLCL:APCLCL,1:$P(APCLSTR,"^",8))
S:APCLCLX="" APCLCLX="E"
S APCLFLG=$S(APCLICD=1:1,1:0) D POV:APCLICD=2,PRC:APCLICD=3
G VST1:'APCLFLG
;
S DFN=$P(APCLSTR,"^",5),APCLNAME=$P(^DPT(DFN,0),"^")
S ^XTMP("APCLYV3",APCLJOB,APCLBT,APCLCLX,APCLNAME,DFN,APCLVDT,APCLVDFN)="" G VST1
;
NEXT ;
S APCLET=$H
Q
;
POV ;does visit have POV within selected range?
S APCLPV=0
PV1 S APCLPV=$O(^AUPNVPOV("AD",APCLVDFN,APCLPV)) Q:APCLPV=""
G PV1:'$D(^AUPNVPOV(APCLPV,0)) S X=$P(^(0),"^") G PV1:'$D(^ICD9(X,0))
;G PV2:APCLBICD["V",PV2:APCLBICD["E"
;I $P($$ICDDX^ICDEX(X),"^",2)'<APCLBICD,($P($$ICDDX^ICDEX(X),"^",2)'>APCLEICD) S APCLFLG=1 Q
I '$D(APCLARRC(X)) G PV1
S APCLFLG=1
G PV1
PV2 ;
I $P($$ICDDX^ICDEX(X),"^",2)'["V"&($P($$ICDDX^ICDEX(X),"^",2)'["E") G PV1
S Y=+$E($P($$ICDDX^ICDEX(X),"^",2),2,9) ;cmi/anch/maw 9/12/2007 csv
I Y'<$E(APCLBICD,2,9),(Y'>$E(APCLEICD,2,9)) S APCLFLG=1 Q
G PV1
;
PRC ;does visit have procedure(s) within selected range?
S APCLPRC=0
PRC1 S APCLPRC=$O(^AUPNVPRC("AD",APCLVDFN,APCLPRC)) Q:APCLPRC=""
G PRC1:'$D(^AUPNVPRC(APCLPRC,0)) S X=$P(^(0),"^")
G PRC1:'$D(^ICD0(X,0))
;I $P(^ICD0(X,0),"^")'<APCLBICD,($P(^ICD0(X,0),"^")'>APCLEICD) S APCLFLG=1 Q ;cmi/anch/maw 9/12/2007 orig line
;I $P($$ICDOP^ICDEX(X),"^",2)'<APCLBICD,($P($$ICDOP^ICDEX(X),"^",2)'>APCLEICD) S APCLFLG=1 Q ;cmi/anch/maw 9/12/2007 csv
I '$D(APCLARRC(X)) G PRC1
S APCLFLG=1
G PRC1
PROV ;check to see if provider is one of the providers
NEW X S X=0 F S X=$O(^AUPNVPRV("AD",APCLVDFN,X)) Q:X'=+X!(APCLFOUN) I APCLPROV=$P(^AUPNVPRV(X,0),U) S APCLFOUN=1
Q
APCLYV31 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning PV1,PV2,PRC
+4 ;
DGZCALL ;EP for DGZCALLS routine
+1 IF '$DATA(APCLBD)!('$DATA(APCLED))
QUIT
+2 IF '$DATA(APCLCL)
Begin DoDot:1
+3 KILL DIC
SET DIC=40.7
SET DIC(0)="M"
SET X=44
DO ^DIC
+4 IF Y=-1
WRITE !!,*7,"DAY SURGERY CODE 44 NOT IN CLINIC STOP FILE!",!!
QUIT
+5 SET APCLCL=+Y
End DoDot:1
+6 IF '$DATA(APCLICD)
SET APCLICD=1
+7 IF '$DATA(APCLBICD)
SET APCLBICD=""
+8 IF '$DATA(APCLEICD)
SET APCLEICD=""
CALC ;find visits by date then store by patient name
+1 ;
+2 SET APCLJOB=$JOB
SET APCLBT=$HOROLOG
+3 DO XTMP^APCLOSUT("APCLYV3","PCC LISTING OF CLINIC VISITS")
+4 SET APCLVDT=APCLBD-.0001
VST SET APCLVDT=$ORDER(^AUPNVSIT("B",APCLVDT))
+1 IF APCLVDT=""
GOTO NEXT
IF APCLVDT>(APCLED+.2359)
GOTO NEXT
SET APCLVDFN=0
VST1 SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLVDT,APCLVDFN))
IF APCLVDFN=""
GOTO VST
+1 ;
+2 IF '$DATA(^AUPNVSIT(APCLVDFN,0))
GOTO VST1
SET APCLSTR=^(0)
+3 ;screen out deleted visits
IF $PIECE(APCLSTR,"^",11)
GOTO VST1
+4 IF $$DEMO^APCLUTL($PIECE(APCLSTR,U,5),$GET(APCLDEMO))
GOTO VST1
+5 IF APCLLOC]""
IF $PIECE(APCLSTR,U,6)'=APCLLOC
GOTO VST1
+6 IF "HDXEIO"[$PIECE(APCLSTR,"^",7)
GOTO VST1
+7 IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLSTR,"^",3)))
GOTO VST1
+8 IF APCLPROV]""
SET APCLFOUN=0
DO PROV
IF 'APCLFOUN
GOTO VST1
+9 IF +APCLCL
IF $PIECE(APCLSTR,"^",8)'=APCLCL
GOTO VST1
+10 IF APCLCL="N"
IF $PIECE(APCLSTR,"^",8)'=""
GOTO VST1
+11 SET APCLCLX=$SELECT(APCLCL=+APCLCL:APCLCL,1:$PIECE(APCLSTR,"^",8))
+12 IF APCLCLX=""
SET APCLCLX="E"
+13 SET APCLFLG=$SELECT(APCLICD=1:1,1:0)
IF APCLICD=2
DO POV
IF APCLICD=3
DO PRC
+14 IF 'APCLFLG
GOTO VST1
+15 ;
+16 SET DFN=$PIECE(APCLSTR,"^",5)
SET APCLNAME=$PIECE(^DPT(DFN,0),"^")
+17 SET ^XTMP("APCLYV3",APCLJOB,APCLBT,APCLCLX,APCLNAME,DFN,APCLVDT,APCLVDFN)=""
GOTO VST1
+18 ;
NEXT ;
+1 SET APCLET=$HOROLOG
+2 QUIT
+3 ;
POV ;does visit have POV within selected range?
+1 SET APCLPV=0
PV1 SET APCLPV=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLPV))
IF APCLPV=""
QUIT
+1 IF '$DATA(^AUPNVPOV(APCLPV,0))
GOTO PV1
SET X=$PIECE(^(0),"^")
IF '$DATA(^ICD9(X,0))
GOTO PV1
+2 ;G PV2:APCLBICD["V",PV2:APCLBICD["E"
+3 ;I $P($$ICDDX^ICDEX(X),"^",2)'<APCLBICD,($P($$ICDDX^ICDEX(X),"^",2)'>APCLEICD) S APCLFLG=1 Q
+4 IF '$DATA(APCLARRC(X))
GOTO PV1
+5 SET APCLFLG=1
+6 GOTO PV1
PV2 ;
+1 IF $PIECE($$ICDDX^ICDEX(X),"^",2)'["V"&($PIECE($$ICDDX^ICDEX(X),"^",2)'["E")
GOTO PV1
+2 ;cmi/anch/maw 9/12/2007 csv
SET Y=+$EXTRACT($PIECE($$ICDDX^ICDEX(X),"^",2),2,9)
+3 IF Y'<$EXTRACT(APCLBICD,2,9)
IF (Y'>$EXTRACT(APCLEICD,2,9))
SET APCLFLG=1
QUIT
+4 GOTO PV1
+5 ;
PRC ;does visit have procedure(s) within selected range?
+1 SET APCLPRC=0
PRC1 SET APCLPRC=$ORDER(^AUPNVPRC("AD",APCLVDFN,APCLPRC))
IF APCLPRC=""
QUIT
+1 IF '$DATA(^AUPNVPRC(APCLPRC,0))
GOTO PRC1
SET X=$PIECE(^(0),"^")
+2 IF '$DATA(^ICD0(X,0))
GOTO PRC1
+3 ;I $P(^ICD0(X,0),"^")'<APCLBICD,($P(^ICD0(X,0),"^")'>APCLEICD) S APCLFLG=1 Q ;cmi/anch/maw 9/12/2007 orig line
+4 ;I $P($$ICDOP^ICDEX(X),"^",2)'<APCLBICD,($P($$ICDOP^ICDEX(X),"^",2)'>APCLEICD) S APCLFLG=1 Q ;cmi/anch/maw 9/12/2007 csv
+5 IF '$DATA(APCLARRC(X))
GOTO PRC1
+6 SET APCLFLG=1
+7 GOTO PRC1
PROV ;check to see if provider is one of the providers
+1 NEW X
SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCLVDFN,X))
IF X'=+X!(APCLFOUN)
QUIT
IF APCLPROV=$PIECE(^AUPNVPRV(X,0),U)
SET APCLFOUN=1
+2 QUIT
