ACHSRDOS ;IHS/OIT/FCJ - ESTIMATED DATE OF SERVICE REPORT FOR CHS [ 07/24/2000 10:57 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001;Build 43
;
S ACHSIO=IO,ACHSPG=0
D BM^ACHSFU
W !,"Report for Actual or Estimated DOS with Issue Date"
DOCS ; Select type of docs to print.
S ACHSRPT=$$DIR^XBDIR("S^1:Actual Date of Service;2:Estimated Date of Service","Print which documents","1","","","^D HELP^ACHS(""H1"",""ACHSRDOS"")",2)
G EXT:$D(DUOUT)!$D(DTOUT)
S ACHSRPT1=$S(ACHSRPT=1:"Actual Date of Service",1:"Estimated Date of Service")
BDT ; Enter beginning date.
S ACHSBDT=$$DATE^ACHS("B",ACHSRPT1,"")
G EXT:$D(DUOUT)!$D(DTOUT)!(ACHSBDT<1)
EDT ; Enter the ending date.
S ACHSEDT=$$DATE^ACHS("E",ACHSRPT1,"")
G BDT:$D(DUOUT),EXT:$D(DTOUT)!(ACHSEDT<1),EDT:$$EBB^ACHS(ACHSBDT,ACHSEDT)
DEV ; Select device for report.
W !
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D EXT Q
I %="B" D VIEWR^XBLM("TRNS^ACHSRDOS"),EN^XBVK("VALM") D EXT Q
K IOP,%ZIS
S %ZIS="PQ"
D ^%ZIS,SLV^ACHSFU:$D(IO("S"))
K %ZIS
I POP W !,*7,"No device specified." D HOME^%ZIS G EXT
G:'$D(IO("Q")) TRNS
K IO("Q")
I $E(IOST)'="P" W *7,!,"Please queue to printers only." G DEV
S ZTIO="",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="TRNS^ACHSRDOS",ZTDESC="CHS "_ACHSRPT1_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)
F %="ACHSQIO","ACHSBDT","ACHSRPT","ACHSEDT","ACHSRPT1" S ZTSAVE(%)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
;
;end of interactive portion. The rest performed by Taskman
;
TRNS ;START OF TRANSACTIONS
W !
S ACHSQUIT=0,ACHSBDT1=ACHSBDT-1
I ACHSRPT=1 F S ACHSBDT1=$O(^ACHSF(DUZ(2),"PDOS",ACHSBDT1)) Q:(ACHSBDT1>ACHSEDT)!(ACHSBDT1="") D Q:ACHSQUIT
.S ACHSDIEN=0 F S ACHSDIEN=$O(^ACHSF(DUZ(2),"PDOS",ACHSBDT1,ACHSDIEN)) Q:ACHSDIEN="" D Q:ACHSQUIT
..S ACHSTIEN=0 F S ACHSTIEN=$O(^ACHSF(DUZ(2),"PDOS",ACHSBDT1,ACHSDIEN,ACHSTIEN)) Q:(ACHSTIEN=ACHSTIEN+1)!(ACHSTIEN="")
..D TRNS2
E F S ACHSBDT1=$O(^ACHSF(DUZ(2),"ES",ACHSBDT1)) Q:(ACHSBDT1>ACHSEDT)!(ACHSBDT1="") D Q:ACHSQUIT
.S ACHSDIEN=0 F S ACHSDIEN=$O(^ACHSF(DUZ(2),"ES",ACHSBDT1,ACHSDIEN)) Q:ACHSDIEN="" D TRNS2 Q:ACHSQUIT
I '$D(ZTSK),'ACHSQUIT D RTRN^ACHS
G EXT
;
TRNS2 ;
S (ACHSPAT,ACHSDOS,ACHSORDT,ACHSCLRK)=""
S ACHSREC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
S ACHSDOC=$P(ACHSREC,"^",14)_"-"_$P(ACHSREC,"^",1)
I $P(ACHSREC,"^",22)="" S ACHSPAT="NONE SPECIFIED"
E S ACHSPAT=$E($P(^DPT($P(ACHSREC,"^",22),0),"^",1),1,23)
S ACHSORDT=$$FMTE^XLFDT($P(ACHSREC,"^",2),"2D")
S ACHSCLRK=$E($P(^VA(200,($P(ACHSREC,"^",18)),0),"^",1),1,15)
I ACHSRPT1=1 S ACHSDOS=$$FMTE^XLFDT($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),"^",10),"2D")
E S ACHSDOS=$$FMTE^XLFDT($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),"^",9),"2D")
D PRINT
Q
PRINT ;
I '$D(ZTSK),$Y>ACHSBM D RTRN^ACHS Q:$D(DUOUT)!$D(DTOUT) D HDR
I ACHSPG=0 D HDR
W !,ACHSDOC,?10,ACHSPAT,?36,ACHSDOS,?48,ACHSORDT,?60,ACHSCLRK
Q
HDR ;
S ACHSPG=ACHSPG+1
W @IOF
I ACHSRPT=1 W !,"DOCUMENT LISTING BY PAID DATE OF SERVICE",?68,"PAGE: ",ACHSPG
E W "DOCUMENT LISTING BY ESTIMATE DATE OF SERVICE",?68,"PAGE: ",ACHSPG
W !!,"P.O. NO. PATIENT NAME "_$S(ACHSRPT=1:"ACT",1:"EST")_" D.O.S. DATE ISSUED ISSUED BY",!
F I=1:1:76 W "-"
Q
EXT ;
K ACHSREC,ACHSDIEN,ACHSTIEN,ACHSPAT,ACHSORDT,ACHSCLRK,ACHSBDT1,ACHSDOC,ACHSDOS
K ACHSQUIT,ACHSRPT1,ACHSDOS
D ERPT^ACHS
Q
H1 ;EP - From HELP^ACHS() via ^DIR.
;;@;!
;;Enter a '1' if you want Actual Date of Service to be listed.
;;Enter a '2' if you want Estimated Date of Service to be listed.
;;###
;
ACHSRDOS ;IHS/OIT/FCJ - ESTIMATED DATE OF SERVICE REPORT FOR CHS [ 07/24/2000 10:57 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001;Build 43
+2 ;
+3 SET ACHSIO=IO
SET ACHSPG=0
+4 DO BM^ACHSFU
+5 WRITE !,"Report for Actual or Estimated DOS with Issue Date"
DOCS ; Select type of docs to print.
+1 SET ACHSRPT=$$DIR^XBDIR("S^1:Actual Date of Service;2:Estimated Date of Service","Print which documents","1","","","^D HELP^ACHS(""H1"",""ACHSRDOS"")",2)
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO EXT
+3 SET ACHSRPT1=$SELECT(ACHSRPT=1:"Actual Date of Service",1:"Estimated Date of Service")
BDT ; Enter beginning date.
+1 SET ACHSBDT=$$DATE^ACHS("B",ACHSRPT1,"")
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHSBDT<1)
GOTO EXT
EDT ; Enter the ending date.
+1 SET ACHSEDT=$$DATE^ACHS("E",ACHSRPT1,"")
+2 IF $DATA(DUOUT)
GOTO BDT
IF $DATA(DTOUT)!(ACHSEDT<1)
GOTO EXT
IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO EDT
DEV ; Select device for report.
+1 WRITE !
+2 SET %=$$PB^ACHS
+3 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO EXT
QUIT
+4 IF %="B"
DO VIEWR^XBLM("TRNS^ACHSRDOS")
DO EN^XBVK("VALM")
DO EXT
QUIT
+5 KILL IOP,%ZIS
+6 SET %ZIS="PQ"
+7 DO ^%ZIS
IF $DATA(IO("S"))
DO SLV^ACHSFU
+8 KILL %ZIS
+9 IF POP
WRITE !,*7,"No device specified."
DO HOME^%ZIS
GOTO EXT
+10 IF '$DATA(IO("Q"))
GOTO TRNS
+11 KILL IO("Q")
+12 IF $EXTRACT(IOST)'="P"
WRITE *7,!,"Please queue to printers only."
GOTO DEV
+13 SET ZTIO=""
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
SET ZTRTN="TRNS^ACHSRDOS"
SET ZTDESC="CHS "_ACHSRPT1_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)
+14 FOR %="ACHSQIO","ACHSBDT","ACHSRPT","ACHSEDT","ACHSRPT1"
SET ZTSAVE(%)=""
+15 DO ^%ZTLOAD
+16 IF '$DATA(ZTSK)
GOTO DEV
+17 ;
+18 ;end of interactive portion. The rest performed by Taskman
+19 ;
TRNS ;START OF TRANSACTIONS
+1 WRITE !
+2 SET ACHSQUIT=0
SET ACHSBDT1=ACHSBDT-1
+3 IF ACHSRPT=1
FOR
SET ACHSBDT1=$ORDER(^ACHSF(DUZ(2),"PDOS",ACHSBDT1))
IF (ACHSBDT1>ACHSEDT)!(ACHSBDT1="")
QUIT
Begin DoDot:1
+4 SET ACHSDIEN=0
FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"PDOS",ACHSBDT1,ACHSDIEN))
IF ACHSDIEN=""
QUIT
Begin DoDot:2
+5 SET ACHSTIEN=0
FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"PDOS",ACHSBDT1,ACHSDIEN,ACHSTIEN))
IF (ACHSTIEN=ACHSTIEN+1)!(ACHSTIEN="")
QUIT
+6 DO TRNS2
End DoDot:2
IF ACHSQUIT
QUIT
End DoDot:1
IF ACHSQUIT
QUIT
+7 IF '$TEST
FOR
SET ACHSBDT1=$ORDER(^ACHSF(DUZ(2),"ES",ACHSBDT1))
IF (ACHSBDT1>ACHSEDT)!(ACHSBDT1="")
QUIT
Begin DoDot:1
+8 SET ACHSDIEN=0
FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"ES",ACHSBDT1,ACHSDIEN))
IF ACHSDIEN=""
QUIT
DO TRNS2
IF ACHSQUIT
QUIT
End DoDot:1
IF ACHSQUIT
QUIT
+9 IF '$DATA(ZTSK)
IF 'ACHSQUIT
DO RTRN^ACHS
+10 GOTO EXT
+11 ;
TRNS2 ;
+1 SET (ACHSPAT,ACHSDOS,ACHSORDT,ACHSCLRK)=""
+2 SET ACHSREC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
+3 SET ACHSDOC=$PIECE(ACHSREC,"^",14)_"-"_$PIECE(ACHSREC,"^",1)
+4 IF $PIECE(ACHSREC,"^",22)=""
SET ACHSPAT="NONE SPECIFIED"
+5 IF '$TEST
SET ACHSPAT=$EXTRACT($PIECE(^DPT($PIECE(ACHSREC,"^",22),0),"^",1),1,23)
+6 SET ACHSORDT=$$FMTE^XLFDT($PIECE(ACHSREC,"^",2),"2D")
+7 SET ACHSCLRK=$EXTRACT($PIECE(^VA(200,($PIECE(ACHSREC,"^",18)),0),"^",1),1,15)
+8 IF ACHSRPT1=1
SET ACHSDOS=$$FMTE^XLFDT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),"^",10),"2D")
+9 IF '$TEST
SET ACHSDOS=$$FMTE^XLFDT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),"^",9),"2D")
+10 DO PRINT
+11 QUIT
PRINT ;
+1 IF '$DATA(ZTSK)
IF $Y>ACHSBM
DO RTRN^ACHS
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
DO HDR
+2 IF ACHSPG=0
DO HDR
+3 WRITE !,ACHSDOC,?10,ACHSPAT,?36,ACHSDOS,?48,ACHSORDT,?60,ACHSCLRK
+4 QUIT
HDR ;
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF
+3 IF ACHSRPT=1
WRITE !,"DOCUMENT LISTING BY PAID DATE OF SERVICE",?68,"PAGE: ",ACHSPG
+4 IF '$TEST
WRITE "DOCUMENT LISTING BY ESTIMATE DATE OF SERVICE",?68,"PAGE: ",ACHSPG
+5 WRITE !!,"P.O. NO. PATIENT NAME "_$SELECT(ACHSRPT=1:"ACT",1:"EST")_" D.O.S. DATE ISSUED ISSUED BY",!
+6 FOR I=1:1:76
WRITE "-"
+7 QUIT
EXT ;
+1 KILL ACHSREC,ACHSDIEN,ACHSTIEN,ACHSPAT,ACHSORDT,ACHSCLRK,ACHSBDT1,ACHSDOC,ACHSDOS
+2 KILL ACHSQUIT,ACHSRPT1,ACHSDOS
+3 DO ERPT^ACHS
+4 QUIT
H1 ;EP - From HELP^ACHS() via ^DIR.
+1 ;;@;!
+2 ;;Enter a '1' if you want Actual Date of Service to be listed.
+3 ;;Enter a '2' if you want Estimated Date of Service to be listed.
+4 ;;###
+5 ;
+6
***** ERRORS & WARNINGS IN ACHSRDOS *****
H1+6 W - Null line (no commands or comment).
