APCLYV31.m

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