Routine: APCLYV12

APCLYV12 ; IHS/CMI/LAB - CO VISITS REPORT (PRINT) ;

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

INIT ;

 S APCLFAC=$P(^DIC(4,DUZ(2),0),"^")

 I '$D(^XTMP("APCLYV1",APCLJOB,APCLBT)) D HEAD W !!,"No visits to report" G END

 S APCLTOT=0,APCLSTOP=""

 S X=132 X ^%ZOSF("RM")

 S APCLBD=$E(APCLBD,4,5)_"/"_$E(APCLBD,6,7)_"/"_$E(APCLBD,2,3)

 S APCLED=$E(APCLED,4,5)_"/"_$E(APCLED,6,7)_"/"_$E(APCLED,2,3)

 S APCLCHMP=$O(^AUTNINS("B","CHAMPUS",0))

 I 'APCLCHMP S APCLCHMP=$O(^AUTNINS("B","TRICARE",0))

MAIN I $D(APCLOP) S APCLII="O" D PRINT,TOTALS G END:APCLSTOP="^"

 I $D(APCLIP) S APCLII="I" D PRINT,TOTALS G END:APCLSTOP="^"

 I $D(APCLDEN) S APCLII="D" D PRINT,TOTALS

END ;

 D DONE^APCLOSUT

 K APCLBD,APCLED,APCLPAT,APCLNAME,APCLHRCN,APCLBEN,APCLII,APCLSTOP,APCLTOT,APCLSUB,Y,APCLRET,APCLRETD,APCLCHMP

 K APCLVDT,APCLVDFN,APCLSSN,APCLFAC,J,APCLDSCH,X,APCLIP,APCLOP,APCLBENP,APCLIDFN,APCLSTR,APCLCFLG

 K APCLDEN,^XTMP("APCLYV1",APCLJOB,APCLBT)

PRINT ;

 D HEAD S APCLBEN=0

P1 S APCLBEN=$O(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN)) Q:APCLBEN=""  S APCLNAME=0

P2 S APCLNAME=$O(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME)) G P1:APCLNAME="" S (APCLPAT,APCLSUB)=0

P3 S APCLPAT=$O(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT)) I APCLPAT="" W:APCLII'="I" ?114,APCLSUB G P2

 S APCLVDT=0

P4 S APCLVDT=$O(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT,APCLVDT)) G P3:APCLVDT="" S APCLVDFN=0

P5 S APCLVDFN=$O(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT,APCLVDT,APCLVDFN)) G P4:APCLVDFN="" S APCLSTR=^(APCLVDFN)

 S APCLHRCN=$P(APCLSTR,"^") S:APCLII="I" APCLDSCH=$P(APCLSTR,"^",2)

 S APCLBENP=$P(^AUTTBEN(APCLBEN,0),"^",2) I APCLBENP="03",'$D(APCLCFLG) S APCLCFLG=""

 I APCLBENP'="03",$D(APCLCFLG) D TOTALS K APCLCFLG D HEAD

 S APCLBENP=$S(APCLBENP="03":"CO",APCLBENP="04":"DEP",APCLBENP="30":"APCLRET",1:"APCLRETD")

 S APCLSSN=$P(^DPT(APCLPAT,0),"^",9)

 S:APCLSSN]"" APCLSSN=$E(APCLSSN,1,3)_"-"_$E(APCLSSN,4,5)_"-"_$E(APCLSSN,6,9)

WRITE ;print line

 D PAGE:$Y>(IOSL-4) Q:APCLSTOP="^"  ;check for end of page

 W:APCLSUB=0 !,$E(APCLNAME,1,20),?23,$J(APCLHRCN,6),?33,APCLSSN,?48,APCLBENP

 I APCLII'="I",(APCLSUB'=0) W !

 D PRVTINS

 S X=$E(APCLVDT,4,5)_"/"_$E(APCLVDT,6,7)_"/"_$E(APCLVDT,2,3) W ?97,X

 I APCLII'="I" S APCLTOT=APCLTOT+1,APCLSUB=APCLSUB+1 G P5

 S X=$S(APCLDSCH="":"",1:$E(APCLDSCH,4,5)_"/"_$E(APCLDSCH,6,7)_"/"_$E(APCLDSCH,2,3))

 W ?110,X S X1=APCLDSCH,X2=APCLVDT D ^%DTC S:X=0 X=1 W ?123,X

 S APCLTOT=APCLTOT+X G P5

HEAD ;print page heading

 W:$D(IOF) @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!

 W !?132-$L(APCLFAC)/2,APCLFAC

 W !?45,"COMMISSIONED OFFICERS & DEPENDENTS VISITS"

 W !?55,APCLBD," to ",APCLED

 S X=$S(APCLII="O":"OUTPATIENT VISITS",APCLII="I":"INPATIENT VISITS",1:"DENTAL VISITS")

 W !?132-$L(X)/2,X,!

 F J=1:1:132 W "-"

 W !,"Patient Name",?23,"Chart #",?36,"SSN",?45,"CO or Dep"

 W ?58,"Sponsor",?80,"SSN"

 W ?97,$S(APCLII="I":"Admit Date",1:"Visit Date")

 W ?110,$S(APCLII="I":"Dsch Date",1:"No. of Visits")

 I APCLII="I" W ?122,"# of Days"

 W ! F J=1:1:132 W "-"

 W ! Q

PAGE ;form feed to new page

 I IOST'?1"C-".E D HEAD Q

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="E" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLSTOP="^" Q

 D HEAD

PRVTINS ;does patient have co dep info in prvt ins file?

 G PRV9:APCLCHMP=""

 G PRV9:APCLBENP="CO",PRV9:APCLBENP="APCLRET"

 S INS=$O(^AUPNPRVT("I",APCLCHMP,APCLPAT,0)) G PRV9:INS=""

 S APCLSTR1=^AUPNPRVT(APCLPAT,11,INS,0) W ?58,$P(APCLSTR1,"^",4)

 S X=$P(APCLSTR1,"^",2) W ?80,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)

PRV9 Q

TOTALS ;print visit totals

 Q:APCLSTOP="^"

 I $Y>(IOSL-6) D PAGE

 I APCLII="O" W !!?80,"TOTAL OUTPATIENT VISITS:",?112,$J(APCLTOT,3)

 I APCLII="I" W !!?95,"TOTAL INPATIENT DAYS:",?121,$J(APCLTOT,3)

 I APCLII="D" W !!?80,"TOTAL DENTAL VISITS:",?112,$J(APCLTOT,3)

 S APCLTOT=0 ;reset for next category

 I IOST?1"C-".E R !!,"Enter <return> to continue or '^' to stop",APCLSTOP:DTIME S:'$T APCLSTOP="^" Q

APCLYV12  ; IHS/CMI/LAB - CO VISITS REPORT (PRINT) ;

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

 +2       ;

INIT      ;

 +1        SET APCLFAC=$PIECE(^DIC(4,DUZ(2),0),"^")

 +2        IF '$DATA(^XTMP("APCLYV1",APCLJOB,APCLBT))

               DO HEAD

               WRITE !!,"No visits to report"

               GOTO END

 +3        SET APCLTOT=0

           SET APCLSTOP=""

 +4        SET X=132

           XECUTE ^%ZOSF("RM")

 +5        SET APCLBD=$EXTRACT(APCLBD,4,5)_"/"_$EXTRACT(APCLBD,6,7)_"/"_$EXTRACT(APCLBD,2,3)

 +6        SET APCLED=$EXTRACT(APCLED,4,5)_"/"_$EXTRACT(APCLED,6,7)_"/"_$EXTRACT(APCLED,2,3)

 +7        SET APCLCHMP=$ORDER(^AUTNINS("B","CHAMPUS",0))

 +8        IF 'APCLCHMP

               SET APCLCHMP=$ORDER(^AUTNINS("B","TRICARE",0))

 +9       ;

MAIN       IF $DATA(APCLOP)

               SET APCLII="O"

               DO PRINT

               DO TOTALS

               IF APCLSTOP="^"

                   GOTO END

 +1        IF $DATA(APCLIP)

               SET APCLII="I"

               DO PRINT

               DO TOTALS

               IF APCLSTOP="^"

                   GOTO END

 +2        IF $DATA(APCLDEN)

               SET APCLII="D"

               DO PRINT

               DO TOTALS

 +3       ;

END       ;

 +1        DO DONE^APCLOSUT

 +2        KILL APCLBD,APCLED,APCLPAT,APCLNAME,APCLHRCN,APCLBEN,APCLII,APCLSTOP,APCLTOT,APCLSUB,Y,APCLRET,APCLRETD,APCLCHMP

 +3        KILL APCLVDT,APCLVDFN,APCLSSN,APCLFAC,J,APCLDSCH,X,APCLIP,APCLOP,APCLBENP,APCLIDFN,APCLSTR,APCLCFLG

 +4        KILL APCLDEN,^XTMP("APCLYV1",APCLJOB,APCLBT)

 +5       ;

 +6        QUIT

PRINT     ;

 +1        DO HEAD

           SET APCLBEN=0

P1         SET APCLBEN=$ORDER(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN))

           IF APCLBEN=""

               QUIT

           SET APCLNAME=0

P2         SET APCLNAME=$ORDER(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME))

           IF APCLNAME=""

               GOTO P1

           SET (APCLPAT,APCLSUB)=0

P3         SET APCLPAT=$ORDER(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT))

           IF APCLPAT=""

               IF APCLII'="I"

                   WRITE ?114,APCLSUB

               GOTO P2

 +1       ;

 +2        SET APCLVDT=0

P4         SET APCLVDT=$ORDER(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT,APCLVDT))

           IF APCLVDT=""

               GOTO P3

           SET APCLVDFN=0

P5         SET APCLVDFN=$ORDER(^XTMP("APCLYV1",APCLJOB,APCLBT,APCLII,APCLBEN,APCLNAME,APCLPAT,APCLVDT,APCLVDFN))

           IF APCLVDFN=""

               GOTO P4

           SET APCLSTR=^(APCLVDFN)

 +1        SET APCLHRCN=$PIECE(APCLSTR,"^")

           IF APCLII="I"

               SET APCLDSCH=$PIECE(APCLSTR,"^",2)

 +2        SET APCLBENP=$PIECE(^AUTTBEN(APCLBEN,0),"^",2)

           IF APCLBENP="03"

               IF '$DATA(APCLCFLG)

                   SET APCLCFLG=""

 +3        IF APCLBENP'="03"

               IF $DATA(APCLCFLG)

                   DO TOTALS

                   KILL APCLCFLG

                   DO HEAD

 +4        SET APCLBENP=$SELECT(APCLBENP="03":"CO",APCLBENP="04":"DEP",APCLBENP="30":"APCLRET",1:"APCLRETD")

 +5        SET APCLSSN=$PIECE(^DPT(APCLPAT,0),"^",9)

 +6        IF APCLSSN]""

               SET APCLSSN=$EXTRACT(APCLSSN,1,3)_"-"_$EXTRACT(APCLSSN,4,5)_"-"_$EXTRACT(APCLSSN,6,9)

 +7       ;

WRITE     ;print line

 +1       ;check for end of page

           IF $Y>(IOSL-4)

               DO PAGE

           IF APCLSTOP="^"

               QUIT

 +2        IF APCLSUB=0

               WRITE !,$EXTRACT(APCLNAME,1,20),?23,$JUSTIFY(APCLHRCN,6),?33,APCLSSN,?48,APCLBENP

 +3        IF APCLII'="I"

               IF (APCLSUB'=0)

                   WRITE !

 +4        DO PRVTINS

 +5        SET X=$EXTRACT(APCLVDT,4,5)_"/"_$EXTRACT(APCLVDT,6,7)_"/"_$EXTRACT(APCLVDT,2,3)

           WRITE ?97,X

 +6        IF APCLII'="I"

               SET APCLTOT=APCLTOT+1

               SET APCLSUB=APCLSUB+1

               GOTO P5

 +7        SET X=$SELECT(APCLDSCH="":"",1:$EXTRACT(APCLDSCH,4,5)_"/"_$EXTRACT(APCLDSCH,6,7)_"/"_$EXTRACT(APCLDSCH,2,3))

 +8        WRITE ?110,X

           SET X1=APCLDSCH

           SET X2=APCLVDT

           DO ^%DTC

           IF X=0

               SET X=1

           WRITE ?123,X

 +9        SET APCLTOT=APCLTOT+X

           GOTO P5

 +10      ;

HEAD      ;print page heading

 +1        IF $DATA(IOF)

               WRITE @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!

 +2        WRITE !?132-$LENGTH(APCLFAC)/2,APCLFAC

 +3        WRITE !?45,"COMMISSIONED OFFICERS & DEPENDENTS VISITS"

 +4        WRITE !?55,APCLBD," to ",APCLED

 +5        SET X=$SELECT(APCLII="O":"OUTPATIENT VISITS",APCLII="I":"INPATIENT VISITS",1:"DENTAL VISITS")

 +6        WRITE !?132-$LENGTH(X)/2,X,!

 +7        FOR J=1:1:132

               WRITE "-"

 +8        WRITE !,"Patient Name",?23,"Chart #",?36,"SSN",?45,"CO or Dep"

 +9        WRITE ?58,"Sponsor",?80,"SSN"

 +10       WRITE ?97,$SELECT(APCLII="I":"Admit Date",1:"Visit Date")

 +11       WRITE ?110,$SELECT(APCLII="I":"Dsch Date",1:"No. of Visits")

 +12       IF APCLII="I"

               WRITE ?122,"# of Days"

 +13       WRITE !

           FOR J=1:1:132

               WRITE "-"

 +14       WRITE !

           QUIT

 +15      ;

PAGE      ;form feed to new page

 +1        IF IOST'?1"C-".E

               DO HEAD

               QUIT

 +2        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLSTOP="^"

                       QUIT

 +3        DO HEAD

 +4        QUIT

 +5       ;

PRVTINS   ;does patient have co dep info in prvt ins file?

 +1        IF APCLCHMP=""

               GOTO PRV9

 +2        IF APCLBENP="CO"

               GOTO PRV9

           IF APCLBENP="APCLRET"

               GOTO PRV9

 +3        SET INS=$ORDER(^AUPNPRVT("I",APCLCHMP,APCLPAT,0))

           IF INS=""

               GOTO PRV9

 +4        SET APCLSTR1=^AUPNPRVT(APCLPAT,11,INS,0)

           WRITE ?58,$PIECE(APCLSTR1,"^",4)

 +5        SET X=$PIECE(APCLSTR1,"^",2)

           WRITE ?80,$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9)

PRV9       QUIT

 +1       ;

TOTALS    ;print visit totals

 +1        IF APCLSTOP="^"

               QUIT

 +2        IF $Y>(IOSL-6)

               DO PAGE

 +3        IF APCLII="O"

               WRITE !!?80,"TOTAL OUTPATIENT VISITS:",?112,$JUSTIFY(APCLTOT,3)

 +4        IF APCLII="I"

               WRITE !!?95,"TOTAL INPATIENT DAYS:",?121,$JUSTIFY(APCLTOT,3)

 +5        IF APCLII="D"

               WRITE !!?80,"TOTAL DENTAL VISITS:",?112,$JUSTIFY(APCLTOT,3)

 +6       ;reset for next category

           SET APCLTOT=0

 +7        IF IOST?1"C-".E

               READ !!,"Enter <return> to continue or '^' to stop",APCLSTOP:DTIME

               IF '$TEST

                   SET APCLSTOP="^"

               QUIT

 +8        QUIT

APCLYV12.m