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 ;
