ACHSSIGA ;IHS/ITSC/JVK -PROGRAM TO LIST SIGNED PO'S WITH E-SIG [ 01/11/2005 7:31 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,19**;JUNE 11,2001
;;ACHS*3.1*7 - NEW ROUTINE E-SIG REPORT OF SIGNED PO'S
;;CALLED BY ACHSESIGRPT
;
TITLE ;;E-Signature Approved
S ACHSIO=IO
S ACHSCNT=0
K X2,X3
BDT ;--ASK THE DATE RANGE--
W !!,"This report captures documents signed over a specific dates range.",!
S ACHSBDT=$$DATE^ACHS("B",$P($T(TITLE),";",3),"E-SIG")
G K:$D(DUOUT)!$D(DTOUT)!(ACHSBDT<1)
EDT ;
S ACHSEDT=$$DATE^ACHS("E",$P($T(TITLE),";",3),"E-SIG")
G K:$D(DTOUT)!(ACHSEDT<1),BDT:$D(DUOUT)
G:$$EBB^ACHS(ACHSBDT,ACHSEDT) EDT
DEV ;
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D K Q
I %="B" D VIEWR^XBLM("PRINT^ACHSSIGA"),EN^XBVK("VALM"),K Q
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS G K
G:'$D(IO("Q")) PRINT
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
;ITSC/SET/JVK ACHS*3.1*12
;S ZTRTN="PRINT^ACHSDST",ZTIO="",ZTDESC=$P($T(TITLE),";",3)_", Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
S ZTRTN="PRINT^ACHSSIGA",ZTIO="",ZTDESC=$P($T(TITLE),";",3)_", Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
F ACHS="ACHSQIO","ACHSBDT","ACHSEDT" S ZTSAVE(ACHS)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ;
K ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK
D ^%ZISC
Q
PRINT ;
D FC^ACHSUF
I $D(ACHSERR),ACHSERR=1 K ZTSK G KILL
D BRPT^ACHSFU
S ACHST1=$$C^XBFUNC("Purchase Orders with Electronic Signature",80)
S ACHST2=$$C^XBFUNC("Duing the Period of "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
D HDR
S X3=0,ACHSBDT=ACHSBDT-1
LOOP1 ;--LOOP THRU THE "ESIG" CROSS REFERENCE--
S ACHSBDT=$O(^ACHSF(DUZ(2),"ESIG",ACHSBDT))
G END:+ACHSBDT=0!(+ACHSBDT>ACHSEDT)
S DA=0
LOOP2 ;
S DA=$O(^ACHSF(DUZ(2),"ESIG",ACHSBDT,DA))
G LOOP1:+DA=0,LOOP1:'$D(^ACHSF(DUZ(2),"D",DA,0))
DATAFLD ;--GET THE DATA FIELDS FOR THE REPORT --
S ACHSDOC1=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSDOC2=$P(^(0),U,14)
S ACHSVPTR=$P(^ACHSF(DUZ(2),"D",DA,0),U,8)
S ACHSODT=$P(^ACHSF(DUZ(2),"D",DA,0),U,2)
S ACHS("$")=$P(^ACHSF(DUZ(2),"D",DA,0),U,9),ACHSESIG=$P(^(0),U,24)
S:'$P(^ACHSF(DUZ(2),"D",DA,0),U,3) ACHSPAT=$P(^(0),U,22),ACHSPAT=$P(^DPT(ACHSPAT,0),U)
I $P(^ACHSF(DUZ(2),"D",DA,0),U,3)=1 S ACHSPAT="BLANKET ORDER" ;ACHS*3.1*19
S ACHSESIG=$P(^VA(200,ACHSESIG,0),U)
S ACHSESIG=$P(ACHSESIG,",",2)_" "_$P(ACHSESIG,",",1)
;**TESTING**
S ACHSASIG=$P($G(^ACHSF(DUZ(2),"D",DA,0)),U,29),ACHSADT=$P($G(^(0)),U,30)
I ACHSASIG S ACHSASIG=$P(^VA(200,ACHSASIG,0),U),ACHSASIG=$P(ACHSASIG,",",2)_" "_$P(ACHSASIG,",",1)
;I 'ACHSASIG,$P(^ACHSESIG(DUZ(2),0),U,2)=0 S ACHSASIG=""
I ACHSASIG="",$P(^ACHSESIG(DUZ(2),0),U,2)=1 S ACHSASIG="NEEDS AUTH. OFC. SIG"
;** END TESTING**
G LOOP1:ACHSVPTR']"",LOOP1:'$D(^AUTTVNDR(ACHSVPTR,0)) S ACHSVNDR=$P(^(0),U)
S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
W !,ACHSDOC,?20,$E(ACHSVNDR,1,26),?48,$E(ACHSBDT,4,7),$E(ACHSBDT,2,3),?58,ACHSESIG,!
;W ACHSPAT,?48,$E(ACHSODT,4,7),$E(ACHSODT,2,3),?58,$FN(ACHS("$"),",",2),!
W ACHSPAT,?20,$FN(ACHS("$"),",",2),?48,$E(ACHSODT,4,7),$E(ACHSODT,2,3),?58,ACHSASIG,!
S ACHSCNT=ACHSCNT+1
G LOOP2
HDR ;
S ACHSPG=ACHSPG+1
W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANNAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?29,"ELECTRONIC SIGNATURE REPORT"
I $D(ZTQUEUED) W ?77-$L(ZTSK),"(",ZTSK,")"
W !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Document Number",?20,"Provider of Service",?48,"Sig Date",?58,"Ordering Official",!
W "Patient",?20,"Oligation Amt.",?48,"Order Dt.",?58,"Authorizing Official",!,$$REPEAT^XLFSTR("=",79),!
Q
END ;
W !,$$REPEAT^XLFSTR("-",79),!
W "Total Documents: ",ACHSCNT,!
D RTRN^ACHS
W @IOF
KILL ;
I $D(ZTQUEUED) K ACHSFC
D ERPT^ACHS
K ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSESIG,ACHSVNDR,ACHSCNT
K DA,DFN,X2,X3
Q
ACHSSIGA ;IHS/ITSC/JVK -PROGRAM TO LIST SIGNED PO'S WITH E-SIG [ 01/11/2005 7:31 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,19**;JUNE 11,2001
+2 ;;ACHS*3.1*7 - NEW ROUTINE E-SIG REPORT OF SIGNED PO'S
+3 ;;CALLED BY ACHSESIGRPT
+4 ;
TITLE ;;E-Signature Approved
+1 SET ACHSIO=IO
+2 SET ACHSCNT=0
+3 KILL X2,X3
BDT ;--ASK THE DATE RANGE--
+1 WRITE !!,"This report captures documents signed over a specific dates range.",!
+2 SET ACHSBDT=$$DATE^ACHS("B",$PIECE($TEXT(TITLE),";",3),"E-SIG")
+3 IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHSBDT<1)
GOTO K
EDT ;
+1 SET ACHSEDT=$$DATE^ACHS("E",$PIECE($TEXT(TITLE),";",3),"E-SIG")
+2 IF $DATA(DTOUT)!(ACHSEDT<1)
GOTO K
IF $DATA(DUOUT)
GOTO BDT
+3 IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO EDT
DEV ;
+1 SET %=$$PB^ACHS
+2 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO K
QUIT
+3 IF %="B"
DO VIEWR^XBLM("PRINT^ACHSSIGA")
DO EN^XBVK("VALM")
DO K
QUIT
+4 SET %ZIS="OPQ"
+5 DO ^%ZIS
+6 IF POP
DO HOME^%ZIS
GOTO K
+7 IF '$DATA(IO("Q"))
GOTO PRINT
+8 KILL IO("Q")
+9 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+10 ;ITSC/SET/JVK ACHS*3.1*12
+11 ;S ZTRTN="PRINT^ACHSDST",ZTIO="",ZTDESC=$P($T(TITLE),";",3)_", Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+12 SET ZTRTN="PRINT^ACHSSIGA"
SET ZTIO=""
SET ZTDESC=$PIECE($TEXT(TITLE),";",3)_", Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+13 FOR ACHS="ACHSQIO","ACHSBDT","ACHSEDT"
SET ZTSAVE(ACHS)=""
+14 DO ^%ZTLOAD
+15 IF '$DATA(ZTSK)
GOTO DEV
K ;
+1 KILL ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK
+2 DO ^%ZISC
+3 QUIT
PRINT ;
+1 DO FC^ACHSUF
+2 IF $DATA(ACHSERR)
IF ACHSERR=1
KILL ZTSK
GOTO KILL
+3 DO BRPT^ACHSFU
+4 SET ACHST1=$$C^XBFUNC("Purchase Orders with Electronic Signature",80)
+5 SET ACHST2=$$C^XBFUNC("Duing the Period of "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
+6 DO HDR
+7 SET X3=0
SET ACHSBDT=ACHSBDT-1
LOOP1 ;--LOOP THRU THE "ESIG" CROSS REFERENCE--
+1 SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"ESIG",ACHSBDT))
+2 IF +ACHSBDT=0!(+ACHSBDT>ACHSEDT)
GOTO END
+3 SET DA=0
LOOP2 ;
+1 SET DA=$ORDER(^ACHSF(DUZ(2),"ESIG",ACHSBDT,DA))
+2 IF +DA=0
GOTO LOOP1
IF '$DATA(^ACHSF(DUZ(2),"D",DA,0))
GOTO LOOP1
DATAFLD ;--GET THE DATA FIELDS FOR THE REPORT --
+1 SET ACHSDOC1=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U)
SET ACHSDOC2=$PIECE(^(0),U,14)
+2 SET ACHSVPTR=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,8)
+3 SET ACHSODT=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,2)
+4 SET ACHS("$")=$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,9)
SET ACHSESIG=$PIECE(^(0),U,24)
+5 IF '$PIECE(^ACHSF(DUZ(2),"D",DA,0),U,3)
SET ACHSPAT=$PIECE(^(0),U,22)
SET ACHSPAT=$PIECE(^DPT(ACHSPAT,0),U)
+6 ;ACHS*3.1*19
IF $PIECE(^ACHSF(DUZ(2),"D",DA,0),U,3)=1
SET ACHSPAT="BLANKET ORDER"
+7 SET ACHSESIG=$PIECE(^VA(200,ACHSESIG,0),U)
+8 SET ACHSESIG=$PIECE(ACHSESIG,",",2)_" "_$PIECE(ACHSESIG,",",1)
+9 ;**TESTING**
+10 SET ACHSASIG=$PIECE($GET(^ACHSF(DUZ(2),"D",DA,0)),U,29)
SET ACHSADT=$PIECE($GET(^(0)),U,30)
+11 IF ACHSASIG
SET ACHSASIG=$PIECE(^VA(200,ACHSASIG,0),U)
SET ACHSASIG=$PIECE(ACHSASIG,",",2)_" "_$PIECE(ACHSASIG,",",1)
+12 ;I 'ACHSASIG,$P(^ACHSESIG(DUZ(2),0),U,2)=0 S ACHSASIG=""
+13 IF ACHSASIG=""
IF $PIECE(^ACHSESIG(DUZ(2),0),U,2)=1
SET ACHSASIG="NEEDS AUTH. OFC. SIG"
+14 ;** END TESTING**
+15 IF ACHSVPTR']""
GOTO LOOP1
IF '$DATA(^AUTTVNDR(ACHSVPTR,0))
GOTO LOOP1
SET ACHSVNDR=$PIECE(^(0),U)
+16 SET ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
+17 WRITE !,ACHSDOC,?20,$EXTRACT(ACHSVNDR,1,26),?48,$EXTRACT(ACHSBDT,4,7),$EXTRACT(ACHSBDT,2,3),?58,ACHSESIG,!
+18 ;W ACHSPAT,?48,$E(ACHSODT,4,7),$E(ACHSODT,2,3),?58,$FN(ACHS("$"),",",2),!
+19 WRITE ACHSPAT,?20,$FNUMBER(ACHS("$"),",",2),?48,$EXTRACT(ACHSODT,4,7),$EXTRACT(ACHSODT,2,3),?58,ACHSASIG,!
+20 SET ACHSCNT=ACHSCNT+1
+21 GOTO LOOP2
HDR ;
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANNAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?29,"ELECTRONIC SIGNATURE REPORT"
+3 IF $DATA(ZTQUEUED)
WRITE ?77-$LENGTH(ZTSK),"(",ZTSK,")"
+4 WRITE !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Document Number",?20,"Provider of Service",?48,"Sig Date",?58,"Ordering Official",!
+5 WRITE "Patient",?20,"Oligation Amt.",?48,"Order Dt.",?58,"Authorizing Official",!,$$REPEAT^XLFSTR("=",79),!
+6 QUIT
END ;
+1 WRITE !,$$REPEAT^XLFSTR("-",79),!
+2 WRITE "Total Documents: ",ACHSCNT,!
+3 DO RTRN^ACHS
+4 WRITE @IOF
KILL ;
+1 IF $DATA(ZTQUEUED)
KILL ACHSFC
+2 DO ERPT^ACHS
+3 KILL ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSESIG,ACHSVNDR,ACHSCNT
+4 KILL DA,DFN,X2,X3
+5 QUIT
