Routine: APCLYV11

APCLYV11 ; IHS/CMI/LAB - PRINT APCLCO VIST REPORT (CALC) ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

INIT ;initialize variables

 S APCLJOB=$J,APCLBT=$H

 D XTMP^APCLOSUT("APCLYV1","PCC COMM OFFS VISITS")

 S APCLCO=$O(^AUTTBEN("C","03",0)),APCLDEP=$O(^AUTTBEN("C","04",0))

 S APCLRET=$O(^AUTTBEN("C","30",0)),APCLRETD=$O(^AUTTBEN("C","31",0))

 I APCLCO="" W !!,"CODE 03 NOT IN BENEFICIARY FILE" G END

 I APCLDEP="" W !!,"CODE 04 NOT IN BENEFICIARY FILE" G END

 I APCLRET="" W !!,"CODE 30 NOT IN BENEFICIARY FILE" G END

 I APCLRETD="" W !!,"CODE 31 NOT IN BENEFICIARY FILE" G END

 S APCLDEN=$O(^DIC(40.7,"C",56,0)) ;dental clinic stop code

 S APCLSD=(9999999-APCLBD)_.2400

MAIN ;

 I APCLCO]"" S APCLII=APCLCO D CALC

 I APCLDEP]"" S APCLII=APCLDEP D CALC

 I APCLRET]"" S APCLII=APCLRET D CALC

 I APCLRETD]"" S APCLII=APCLRETD D CALC

END ;

 S APCLET=$H

CALC ;find patients and their visits

 S APCLPAT=0

PAT S APCLPAT=$O(^AUPNPAT("AD",APCLII,APCLPAT)) Q:APCLPAT=""

 G PAT:$$DEMO^APCLUTL(APCLPAT,$G(APCLDEMO))

 G PAT:'$D(^AUPNPAT(APCLPAT,41,DUZ(2))) ;must have hrcn at your facility

 S APCLHRCN=$P(^AUPNPAT(APCLPAT,41,DUZ(2),0),"^",2)

 G PAT:'$D(^DPT(APCLPAT,0)) S APCLNAME=$P(^(0),"^")

 S APCLEDT=9999999-APCLED-.0001

VST S APCLEDT=$O(^AUPNVSIT("AA",APCLPAT,APCLEDT)) G PAT:APCLEDT="",PAT:APCLEDT>APCLSD S APCLVDFN=0

VST1 S APCLVDFN=$O(^AUPNVSIT("AA",APCLPAT,APCLEDT,APCLVDFN)) G VST:APCLVDFN=""

 G VST1:'$D(^AUPNVSIT(APCLVDFN,0)) S APCLSTR=^(0)

 G VST1:$P(APCLSTR,"^",11) ;screen out deleted visits

 G VST1:$P(APCLSTR,"^",6)'=DUZ(2) ;screen out visits at other facilities

 S APCLVDT=$P(APCLSTR,"^"),X=$P(APCLSTR,"^",7)

 I (X'="A")&(X'="H")&(X'="S") G VST1

 ;set dental visits

 I $P(APCLSTR,"^",8)=APCLDEN,$D(APCLDEN) S ^XTMP("APCLYV1",APCLJOB,APCLBT,"D",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN G VST1

 ;set outpt node

 I X'="H",$D(APCLOP) S ^XTMP("APCLYV1",APCLJOB,APCLBT,"O",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN G VST1

 ;set inpt node

 G VST1:'$D(APCLIP) S APCLIDFN=$O(^AUPNVINP("AD",APCLVDFN,0)) G VST1:APCLIDFN=""

 S APCLDSCH=+^AUPNVINP(APCLIDFN,0)

 S ^XTMP("APCLYV1",APCLJOB,APCLBT,"I",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN_"^"_APCLDSCH G VST1

APCLYV11  ; IHS/CMI/LAB - PRINT APCLCO VIST REPORT (CALC) ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

INIT      ;initialize variables

 +1        SET APCLJOB=$JOB

           SET APCLBT=$HOROLOG

 +2        DO XTMP^APCLOSUT("APCLYV1","PCC COMM OFFS VISITS")

 +3        SET APCLCO=$ORDER(^AUTTBEN("C","03",0))

           SET APCLDEP=$ORDER(^AUTTBEN("C","04",0))

 +4        SET APCLRET=$ORDER(^AUTTBEN("C","30",0))

           SET APCLRETD=$ORDER(^AUTTBEN("C","31",0))

 +5        IF APCLCO=""

               WRITE !!,"CODE 03 NOT IN BENEFICIARY FILE"

               GOTO END

 +6        IF APCLDEP=""

               WRITE !!,"CODE 04 NOT IN BENEFICIARY FILE"

               GOTO END

 +7        IF APCLRET=""

               WRITE !!,"CODE 30 NOT IN BENEFICIARY FILE"

               GOTO END

 +8        IF APCLRETD=""

               WRITE !!,"CODE 31 NOT IN BENEFICIARY FILE"

               GOTO END

 +9       ;dental clinic stop code

           SET APCLDEN=$ORDER(^DIC(40.7,"C",56,0))

 +10       SET APCLSD=(9999999-APCLBD)_.2400

 +11      ;

MAIN      ;

 +1        IF APCLCO]""

               SET APCLII=APCLCO

               DO CALC

 +2        IF APCLDEP]""

               SET APCLII=APCLDEP

               DO CALC

 +3        IF APCLRET]""

               SET APCLII=APCLRET

               DO CALC

 +4        IF APCLRETD]""

               SET APCLII=APCLRETD

               DO CALC

END       ;

 +1        SET APCLET=$HOROLOG

 +2        QUIT

 +3       ;

CALC      ;find patients and their visits

 +1        SET APCLPAT=0

PAT        SET APCLPAT=$ORDER(^AUPNPAT("AD",APCLII,APCLPAT))

           IF APCLPAT=""

               QUIT

 +1        IF $$DEMO^APCLUTL(APCLPAT,$GET(APCLDEMO))

               GOTO PAT

 +2       ;must have hrcn at your facility

           IF '$DATA(^AUPNPAT(APCLPAT,41,DUZ(2)))

               GOTO PAT

 +3        SET APCLHRCN=$PIECE(^AUPNPAT(APCLPAT,41,DUZ(2),0),"^",2)

 +4        IF '$DATA(^DPT(APCLPAT,0))

               GOTO PAT

           SET APCLNAME=$PIECE(^(0),"^")

 +5       ;

 +6        SET APCLEDT=9999999-APCLED-.0001

VST        SET APCLEDT=$ORDER(^AUPNVSIT("AA",APCLPAT,APCLEDT))

           IF APCLEDT=""

               GOTO PAT

           IF APCLEDT>APCLSD

               GOTO PAT

           SET APCLVDFN=0

VST1       SET APCLVDFN=$ORDER(^AUPNVSIT("AA",APCLPAT,APCLEDT,APCLVDFN))

           IF APCLVDFN=""

               GOTO VST

 +1        IF '$DATA(^AUPNVSIT(APCLVDFN,0))

               GOTO VST1

           SET APCLSTR=^(0)

 +2       ;screen out deleted visits

           IF $PIECE(APCLSTR,"^",11)

               GOTO VST1

 +3       ;screen out visits at other facilities

           IF $PIECE(APCLSTR,"^",6)'=DUZ(2)

               GOTO VST1

 +4       ;

 +5        SET APCLVDT=$PIECE(APCLSTR,"^")

           SET X=$PIECE(APCLSTR,"^",7)

 +6        IF (X'="A")&(X'="H")&(X'="S")

               GOTO VST1

 +7       ;set dental visits

 +8        IF $PIECE(APCLSTR,"^",8)=APCLDEN

               IF $DATA(APCLDEN)

                   SET ^XTMP("APCLYV1",APCLJOB,APCLBT,"D",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN

                   GOTO VST1

 +9       ;set outpt node

 +10       IF X'="H"

               IF $DATA(APCLOP)

                   SET ^XTMP("APCLYV1",APCLJOB,APCLBT,"O",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN

                   GOTO VST1

 +11      ;set inpt node

 +12       IF '$DATA(APCLIP)

               GOTO VST1

           SET APCLIDFN=$ORDER(^AUPNVINP("AD",APCLVDFN,0))

           IF APCLIDFN=""

               GOTO VST1

 +13       SET APCLDSCH=+^AUPNVINP(APCLIDFN,0)

 +14       SET ^XTMP("APCLYV1",APCLJOB,APCLBT,"I",APCLII,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)=APCLHRCN_"^"_APCLDSCH

           GOTO VST1

 +15      ;

 +16       QUIT

APCLYV11.m