Routine: ACHSSIGA

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

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),!

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

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

ACHSSIGA.m