ACHSPCC5.m

ACHSPCC5 ; IHS/ITSC/PMF - CHS AREA SPLITOUT (5/5)(LIST GENERATED DHRS) ;    [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ;

 I '$O(^ACHSPCC(0)) W *7,!!,"No data in ^ACHSPCC.",$$DIR^XBDIR("E","Press RETURN...") Q

 S ACHSCCTR=$G(ACHSCCTR)

 D HOME^%ZIS,NOW^ACHS,LINES^ACHSFU

 S ACHSIO=IO,ACHSAST=ACHS("*"),ACHS("R")=$O(^ACHSPCC(0)),ACHS("SITE")=$$LOC^ACHS

 U IO(0)

 W @IOF,!,ACHS("*"),!,"*",?27,"CHS DATA TRANSMITTED TO ",ACHSCCTR,?78,"*",!,"*",?40-(($L(ACHSTIME)+6)\2),"as of ",ACHSTIME,?78,"*",!,"*",?40-(($L(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),?78,"*",!,ACHS("*"),!

FMT ;

 S Y=$$DIR^XBDIR("SOB^R:Raw;C:Captioned;B:Both","[R]aw, [C]aptioned, or [B]oth","B","","Do you want a printout of Raw DHR data, Captioned, or Both","",1)

 G END:$D(DUOUT)!$D(DTOUT)

 S ACHSCAP=$S("BC"[Y:1,1:0),ACHSRAW=$S("BR"[Y:1,1:0)

DEV ;

 S %=$$PB^ACHS

 I %=U!$D(DTOUT)!$D(DUOUT) D K Q

 I %="B" D VIEWR^XBLM("START^ACHSPCC5"),EN^XBVK("VALM"),K Q

 S %ZIS="OPQ"

 D ^%ZIS

 K %ZIS

 I POP D HOME^%ZIS D K Q

 G:'$D(IO("Q")) START

 K IO("Q")

 I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV

 S X=$$AOP^ACHS(2,8),X=$S('(X="Y"):"Parklawn Comp Ctr",X="Y":"Blue Cross/Shield",1:" ")

 S ZTRTN="START^ACHSPCC5",ZTDESC="List of DHRs Xmitted to "_X_", for "_$P(^AUTTLOC(DUZ(2),0),U,2)_"."

 S ACHSAST=ACHS("*")

 F %="ACHSCAP","ACHSRAW","ACHSAST","ACHSCCTR" S ZTSAVE(%)=""

 D ^%ZTLOAD

 G:'$D(ZTSK) DEV

K ;

 K ZTDESC,ZTRTN,ZTSK

 D ^%ZISC,EN^XBVK("ACHS"),^ACHSVAR

 Q

 ;

START ;EP - TaskMan.

 S (ACHSR,ACHSRR,ACHSRCT,ACHSTDHR,ACHSFDHR,ACHSPG)=0,ACHS("R")=$O(^ACHSPCC(0))

 D SITENAME,NOW^ACHS

 U IO

 D H1

L2 ;

 S ACHSR=$O(^ACHSPCC(ACHSR))

 G LEND:ACHSR=""!(ACHSR'=+ACHSR)

 I ACHSR'=ACHS("R") S ACHS("R")=ACHSR D SITENAME,H1 S ACHSFDHR=0

L3 ;

 S ACHSRR=$O(^ACHSPCC(ACHSR,ACHSRR))

 G L2:ACHSRR=""

 S ACHSRCT=ACHSRCT+1

 I $Y>(IOSL-5) D RTRN^ACHS G:$D(DUOUT)!$D(DTOUT) END D H1

 S X=$G(^ACHSPCC(ACHSR,ACHSRR))

 I $E(X,79,80)="99" G L3

 S ACHSTDHR=ACHSTDHR+1,ACHSFDHR=ACHSFDHR+1

 I ACHSRAW W X,! D:ACHSCAP H2

 I '(ACHSFDHR#5),ACHSRAW,'ACHSCAP D H2

 G:'ACHSCAP L3

 W !,"DOCUMENT NUMBER : ",$E(X,17),"-",$E(X,18,20),"-",$E(X,21,25),!?2,"EFFECTIVE DATE (MMDDYY): ",$E(X,2,3),"-",$E(X,4,5),"-",$E(X,6,7),?40,"COMMON ACCOUNTING NUMBER : ",$E(X,41,47)

 W !?8,"DESTINATION CODE : ",$E(X,8,12),?47,"OBJECT CLASS CODE : ",$E(X,48,49),".",$E(X,50,51)

 W !?16,"REF CODE : ",$E(X,13,15),?46,"IHS PAYMENT AMOUNT : ",+$E(X,52,61),".",$E(X,62,63)

 W !?13,"FISCAL YEAR : ",$E(X,40),?48,"FED/NON-FED CODE : ",$E(X,64),!

 W:ACHSRAW !

 G L3

 ;

LEND ;

 D H2

 W !!,"DHRs : ",ACHSTDHR,!!,"TOTAL RECORDS = ",ACHSRCT

 D RTRN^ACHS,H1

 W !!,"DHR record layout:",!!!?5,"1",?8,"RECORD TYPE (2)",!?5,"2",?8,"EFFECTIVE DATE (MMDDYY)",!?5,"8",?8,"DESTINATION CODE",!?4,"13",?8,"323, 324, OR 325"

 W !?4,"16",?8,"DOCUMENT NUMBER",!?4,"26",?8,"If '05024', repeat 13-25, else blanks",!?4,"39",?8,"constant=1",!?4,"40",?8,"FISCAL YEAR",!?4,"41",?8,"COMMON ACCOUNTING NUMBER",!?4,"48",?8,"OBJECT CLASS CODE",!?4,"52",?8,"IHS PAYMENT AMOUNT"

 W !?4,"64",?8,"FED/NON-FED CODE",!?4,"65",?8,"blanks"

 D RTRN^ACHS

 W @IOF

END ;

 D EN^XBVK("ACHS"),^ACHSVAR

 K DTOUT,DUOUT,X,Y

 D ^%ZISC

 Q

 ;

H1 ;

 S ACHSPG=ACHSPG+1

 W @IOF,!,ACHSAST,!,"*",?25,"CHS DHR DATA TRANSMITTED TO ",ACHSCCTR,?67,"Page ",$J(ACHSPG,3),?78,"*",!,"*",?40-(($L(ACHSTIME)+6)\2),"as of ",ACHSTIME,?78,"*",!,"*",?40-(($L(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),?78,"*",!,ACHSAST,!!!

 Q

 ;

H2 ;

 W ?4,"+",?9,"1",?14,"+",?19,"2",?24,"+",?29,"3",?34,"+",?39,"4",?44,"+",?49,"5",?54,"+",?59,"6",?64,"+",?69,"7",?74,"+"

 W:'ACHSCAP !

 Q

 ;

SITENAME ;

 S ACHS("SITE")=$P(^DIC(4,$O(^AUTTLOC("C",ACHS("R"),0)),0),U)

 Q

 ;

ACHSPCC5  ; IHS/ITSC/PMF - CHS AREA SPLITOUT (5/5)(LIST GENERATED DHRS) ;    [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

 +3        IF '$ORDER(^ACHSPCC(0))

               WRITE *7,!!,"No data in ^ACHSPCC.",$$DIR^XBDIR("E","Press RETURN...")

               QUIT 

 +4        SET ACHSCCTR=$GET(ACHSCCTR)

 +5        DO HOME^%ZIS

           DO NOW^ACHS

           DO LINES^ACHSFU

 +6        SET ACHSIO=IO

           SET ACHSAST=ACHS("*")

           SET ACHS("R")=$ORDER(^ACHSPCC(0))

           SET ACHS("SITE")=$$LOC^ACHS

 +7        USE IO(0)

 +8        WRITE @IOF,!,ACHS("*"),!,"*",?27,"CHS DATA TRANSMITTED TO ",ACHSCCTR,?78,"*",!,"*",?40-(($LENGTH(ACHSTIME)+6)\2),"as of ",ACHSTIME,?78,"*",!,"*",?40-(($LENGTH(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),?78,"*",!,ACHS("*"),!

FMT       ;

 +1        SET Y=$$DIR^XBDIR("SOB^R:Raw;C:Captioned;B:Both","[R]aw, [C]aptioned, or [B]oth","B","","Do you want a printout of Raw DHR data, Captioned, or Both","",1)

 +2        IF $DATA(DUOUT)!$DATA(DTOUT)

               GOTO END

 +3        SET ACHSCAP=$SELECT("BC"[Y:1,1:0)

           SET ACHSRAW=$SELECT("BR"[Y:1,1:0)

DEV       ;

 +1        SET %=$$PB^ACHS

 +2        IF %=U!$DATA(DTOUT)!$DATA(DUOUT)

               DO K

               QUIT 

 +3        IF %="B"

               DO VIEWR^XBLM("START^ACHSPCC5")

               DO EN^XBVK("VALM")

               DO K

               QUIT 

 +4        SET %ZIS="OPQ"

 +5        DO ^%ZIS

 +6        KILL %ZIS

 +7        IF POP

               DO HOME^%ZIS

               DO K

               QUIT 

 +8        IF '$DATA(IO("Q"))

               GOTO START

 +9        KILL IO("Q")

 +10       IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")

               WRITE *7,!,"Please queue to system printers."

               DO ^%ZISC

               GOTO DEV

 +11       SET X=$$AOP^ACHS(2,8)

           SET X=$SELECT('(X="Y"):"Parklawn Comp Ctr",X="Y":"Blue Cross/Shield",1:" ")

 +12       SET ZTRTN="START^ACHSPCC5"

           SET ZTDESC="List of DHRs Xmitted to "_X_", for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."

 +13       SET ACHSAST=ACHS("*")

 +14       FOR %="ACHSCAP","ACHSRAW","ACHSAST","ACHSCCTR"

               SET ZTSAVE(%)=""

 +15       DO ^%ZTLOAD

 +16       IF '$DATA(ZTSK)

               GOTO DEV

K         ;

 +1        KILL ZTDESC,ZTRTN,ZTSK

 +2        DO ^%ZISC

           DO EN^XBVK("ACHS")

           DO ^ACHSVAR

 +3        QUIT 

 +4       ;

START     ;EP - TaskMan.

 +1        SET (ACHSR,ACHSRR,ACHSRCT,ACHSTDHR,ACHSFDHR,ACHSPG)=0

           SET ACHS("R")=$ORDER(^ACHSPCC(0))

 +2        DO SITENAME

           DO NOW^ACHS

 +3        USE IO

 +4        DO H1

L2        ;

 +1        SET ACHSR=$ORDER(^ACHSPCC(ACHSR))

 +2        IF ACHSR=""!(ACHSR'=+ACHSR)

               GOTO LEND

 +3        IF ACHSR'=ACHS("R")

               SET ACHS("R")=ACHSR

               DO SITENAME

               DO H1

               SET ACHSFDHR=0

L3        ;

 +1        SET ACHSRR=$ORDER(^ACHSPCC(ACHSR,ACHSRR))

 +2        IF ACHSRR=""

               GOTO L2

 +3        SET ACHSRCT=ACHSRCT+1

 +4        IF $Y>(IOSL-5)

               DO RTRN^ACHS

               IF $DATA(DUOUT)!$DATA(DTOUT)

                   GOTO END

               DO H1

 +5        SET X=$GET(^ACHSPCC(ACHSR,ACHSRR))

 +6        IF $EXTRACT(X,79,80)="99"

               GOTO L3

 +7        SET ACHSTDHR=ACHSTDHR+1

           SET ACHSFDHR=ACHSFDHR+1

 +8        IF ACHSRAW

               WRITE X,!

               IF ACHSCAP

                   DO H2

 +9        IF '(ACHSFDHR#5)

               IF ACHSRAW

                   IF 'ACHSCAP

                       DO H2

 +10       IF 'ACHSCAP

               GOTO L3

 +11       WRITE !,"DOCUMENT NUMBER : ",$EXTRACT(X,17),"-",$EXTRACT(X,18,20),"-",$EXTRACT(X,21,25),!?2,"EFFECTIVE DATE (MMDDYY): ",$EXTRACT(X,2,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,7),?40,"COMMON ACCOUNTING NUMBER : ",$EXTRACT(X,41,47)

 +12       WRITE !?8,"DESTINATION CODE : ",$EXTRACT(X,8,12),?47,"OBJECT CLASS CODE : ",$EXTRACT(X,48,49),".",$EXTRACT(X,50,51)

 +13       WRITE !?16,"REF CODE : ",$EXTRACT(X,13,15),?46,"IHS PAYMENT AMOUNT : ",+$EXTRACT(X,52,61),".",$EXTRACT(X,62,63)

 +14       WRITE !?13,"FISCAL YEAR : ",$EXTRACT(X,40),?48,"FED/NON-FED CODE : ",$EXTRACT(X,64),!

 +15       IF ACHSRAW

               WRITE !

 +16       GOTO L3

 +17      ;

LEND      ;

 +1        DO H2

 +2        WRITE !!,"DHRs : ",ACHSTDHR,!!,"TOTAL RECORDS = ",ACHSRCT

 +3        DO RTRN^ACHS

           DO H1

 +4        WRITE !!,"DHR record layout:",!!!?5,"1",?8,"RECORD TYPE (2)",!?5,"2",?8,"EFFECTIVE DATE (MMDDYY)",!?5,"8",?8,"DESTINATION CODE",!?4,"13",?8,"323, 324, OR 325"

 +5        WRITE !?4,"16",?8,"DOCUMENT NUMBER",!?4,"26",?8,"If '05024', repeat 13-25, else blanks",!?4,"39",?8,"constant=1",!?4,"40",?8,"FISCAL YEAR",!?4,"41",?8,"COMMON ACCOUNTING NUMBER",!?4,"48",?8,"OBJECT CLASS CODE",!?4,"52",?8,"IHS PAYMENT AMOUNT"

 +6        WRITE !?4,"64",?8,"FED/NON-FED CODE",!?4,"65",?8,"blanks"

 +7        DO RTRN^ACHS

 +8        WRITE @IOF

END       ;

 +1        DO EN^XBVK("ACHS")

           DO ^ACHSVAR

 +2        KILL DTOUT,DUOUT,X,Y

 +3        DO ^%ZISC

 +4        QUIT 

 +5       ;

H1        ;

 +1        SET ACHSPG=ACHSPG+1

 +2        WRITE @IOF,!,ACHSAST,!,"*",?25,"CHS DHR DATA TRANSMITTED TO ",ACHSCCTR,?67,"Page ",$JUSTIFY(ACHSPG,3),?78,"*",!,"*",?40-(($LENGTH(ACHSTIME)+6)\2),"as of ",ACHSTIME,?78,"*",!,"*",?40-(($LENGTH(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),?78,"*",!,AC

HSAST,!!!

 +3        QUIT 

 +4       ;

H2        ;

 +1        WRITE ?4,"+",?9,"1",?14,"+",?19,"2",?24,"+",?29,"3",?34,"+",?39,"4",?44,"+",?49,"5",?54,"+",?59,"6",?64,"+",?69,"7",?74,"+"

 +2        IF 'ACHSCAP

               WRITE !

 +3        QUIT 

 +4       ;

SITENAME  ;

 +1        SET ACHS("SITE")=$PIECE(^DIC(4,$ORDER(^AUTTLOC("C",ACHS("R"),0)),0),U)

 +2        QUIT 

 +3       ;