ACHSSIG2 ;IHS/ITSC/JVK-STAMP ELECTRONIC SIGNATURE OF AUTHORIZING OFC. ON PO [ 01/11/2005 7:33 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,9,12**;JUNE 11,2001
;;ACHS*3.1*7-ALLOWING AUTHRIZING OFFICIAL E SIG
;;ACHS*3.1*8-FIX LIST FOR SPECIAL LOCALS
;;NEW ROUTINE CALLED FROM ACHS E-SIG MENU OPTION
;;3.1 8.23.04 IHS/ITSC/FCJ LOOP WAS NOT PICKING UP DOCUMENTS IF TYPE 1
; DID NOT EXIST
;
LOOK ;EP
S ACHSANS=""
I '$D(^ACHSF("EAQ",DUZ(2))) D Q
. W !,"There are no documents in the Queue!"
. D RTRN^ACHS
S ACHSIO=IO
K X2,X3
;
START ;
D BM^ACHS
S ACHSFC=$$FC^ACHS(DUZ(2))
S COUNT=0
S ACHSQUIT=0
S ACHSMULT=$P(^ACHSESIG(DUZ(2),0),U,2)
I 'ACHSMULT W !!!,?5,"YOUR SITE PARAMETERS INDICATE THIS IS NOT A MULTIPLE SIGNATURE SITE.",!,?5,"THIS OPTION IS NOT AVAILABLE FOR USE." H 3 D END Q
D CHECK
I ACHSQUIT G END
;
LOOP1 ;--LOOP THRU QUEUE ARRAY FOR DOCUMENTS WAITING --
;ITSC/SET/JVK ACHS**
S ACHSGO=0
F ACHSTYPV=1,3,2 D LOOP2 Q:$D(DUOUT)!ACHSQUIT
;
I ACHSGO>0,ACHSSIG'="" G A
;
;ITSC/SET/JVK ACHS*3.1*12
;I 'ACHSGO W !,?5,"No Documents Pending for your Signature.",! H 2 G END
I ACHSGO'>0 W !,?5,"No Documents Pending for your Signature.",! H 2 G END
;
I $D(DUOUT)!$D(DTOUT) D END Q
;
LOOP2 ;--SECOND LEVEL OF QUEUE ARRAY SET UP ACHSTMP ARRAY--
Q:'$D(^ACHSF("EAQ",DUZ(2),ACHSTYPV)) ;8.23.04 IHS/ITSC/FCJ TEST FOR DOC TYPE
S ACHSDIEN=""
S ACHSFLG=""
F S ACHSDIEN=$O(^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0!$D(DUOUT) D
.S ACHSDOC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
.S ACHSTST1=$P(ACHSDOC,U,24)
.S ACHSTST2=$P(ACHSDOC,U,29)
.;TEST FOR ORDER AND AUTHROIZING NOT TO BE THE SAME PERSON
.I ACHSTST1=DUZ Q
.S ACHSAMT=$P(ACHSDOC,U,9)
.I ACHSAMT>ACHSDAMT Q
.I ACHSTST2="" S COUNT=COUNT+1,ACHSTMP(DUZ(2),COUNT)=ACHSDIEN_U_ACHSAMT,ACHSFLG=1
.S ACHSGO=COUNT
Q
;
A ;--SET UP LIST MANAGER--
D VIEWR^XBLM("PRINT^ACHSSIG2")
D STAMP
Q
;
PRINT ;
D FC^ACHSUF
D BRPT^ACHSFU
S ACHST1=$$C^XBFUNC("Purchase Orders to be Approved",80)
D HDR
S X3=0
S COUNT=""
F S COUNT=$O(ACHSTMP(DUZ(2),COUNT)) Q:COUNT'?1N.N D
.S ACHSDOC=^ACHSF(DUZ(2),"D",$P(ACHSTMP(DUZ(2),COUNT),U),0)
.S ACHSTYP=$P(ACHSDOC,U,4)
.S ACHSLST=$S(ACHSTYP=1:"Hospital",ACHSTYP=3:"Outpatient",ACHSTYP=2:"Dental",1:"")
.D LIST
Q
;
CHECK ;--IS THE USER AUTHORIZED IN THE CHS E-SIG FILE--
S ACHSAU=""
S ACHSAU=$O(^ACHSESIG(DUZ(2),1,"B",DUZ,ACHSAU))
I ACHSAU D
.K DIC,DIQ
.S DIC=9002080.1,DR=".01;1",DA=DUZ(2)
.S DR(9002080.11)="1:2:3",DA(9002080.11)=ACHSAU,DIQ="ACHSVAL" D EN^DIQ1
.S ACHSDAMT=$P($G(ACHSVAL(9002080.11,ACHSAU,1)),U)
.S ACHSADT=$P($G(ACHSVAL(9002080.11,ACHSAU,2)),U)
.S ACHSIADT=$P($G(ACHSVAL(9002080.11,ACHSAU,3)),U)
.S ACHSIGO=$P($G(ACHSVAL(9002090.11,ACHSAU,4)),U) ;ORDERING OFFICIAL
.S ACHSIGA=$P($G(ACHSVAL(9002090.11,ACHSAU,5)),U) ;AUTHORIZING OFFICAL
.Q
D SIG^XUSESIG
S ACHSSIG=X1
I 'ACHSAU W !,"You are not authorized in the CHS E-SIG file.",! H 2 S ACHSQUIT=1 Q
I ACHSIGA["NO",ACHSIGA="" W !,"You are not an authorized Authorizing Official.",! H 2 S ACHSQUIT=1
Q
STAMP ;--ASK IF YOU WANT ALL OR REMOVE ITEMS FROM LIST OF SET--
I ACHSSIG'="" S ACHSANS=$$DIR^XBDIR("Y","Do you want ALL documents stamped with your Electronic signature ","N","","","",1)
I $D(DUOUT)!$D(DTOUT) D END Q
I ACHSANS D LOOP3,END Q
I 'ACHSANS D RMITMS,ASK
Q
LIST ;--LIST ONLY THOSE PO W/OUT SIG IN FILE--
W !,COUNT,?9,$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U,1) ;Order No
W ?25,$P(^AUTTVNDR($P(ACHSDOC,U,8),0),U) ;Vendor
W ?55,$FN($P(ACHSDOC,U,9),",",2) ;Total Amount Obligated
;W !,?9,"CAN-OCC-SCC: ",$P(^ACHS(2,$P(ACHSDOC,U,6),0),U),"-",$P(^ACHSOCC($P(ACHSDOC,U,7),0),U),"-",$P(^ACHS(3,DUZ(2),1,$P(ACHSDOC,U,10),0),U),?50,ACHSLST ;CAN & Obj Class
W !,?9,"CAN-OCC-SCC: ",$P(^ACHS(2,$P(ACHSDOC,U,6),0),U),"-",$P(^ACHSOCC($P(ACHSDOC,U,10),0),U),"-",$P(^ACHS(3,DUZ(2),1,$P(ACHSDOC,U,7),0),U),?50,ACHSLST ;CAN & Obj Class
;ITSC/SET/JVK 2-18-2004
;W:$P(ACHSDOC,U,3)'=1 !,?9,$P(^DPT($P(ACHSDOC,U,22),0),U),! ;Patient
I $P(ACHSDOC,U,3)=0 W !,?9,$P(^DPT($P(ACHSDOC,U,22),0),U),! ;Patient
I $P(ACHSDOC,U,3) W !,?9,"--Blanket Order/Special Local--",!
Q
RMITMS ;--REMOVE THE ITEM FROM THE SET--
S ACHSQUE=$$DIR^XBDIR("L^0:1000","Select the ITEM NO. that you DO NOT want your Electronic signature applied to ","","Enter zero for none.","","",2)
I ACHSQUE["^" G END Q
I $D(DUOUT)!$D(DTOUT) G ASK
;I Y'=0,'$D(ACHSTMP(DUZ(2),Y)) D RMITMS ;TEST FOR NUMBERS ALREADY GONE
I Y=0 Q
S ACHSITM=0
F ACHSI=1:1 Q:ACHSITM="" D
.S ACHSITM=$P(Y,",",ACHSI)
.Q:ACHSITM=""
.Q:ACHSITM=0
.Q:'$D(ACHSTMP(DUZ(2),ACHSITM))
.K ACHSTMP(DUZ(2),ACHSITM)
.Q
Q
LOOP3 ;--STUFF THE USER AND DATE OF ALL AUTHORIZED--
S COUNT=""
S ACHSSUM=0
F S COUNT=$O(ACHSTMP(DUZ(2),COUNT)) Q:COUNT'?1N.N D
.S ACHSDOC=^ACHSF(DUZ(2),"D",$P(ACHSTMP(DUZ(2),COUNT),U),0)
.S ACHSDIEN=$P(ACHSTMP(DUZ(2),COUNT),U)
.S ACHSAMT=$P(ACHSTMP(DUZ(2),COUNT),U,2) ;DOCUMENT AMOUNT
.S ACHSTYPV=$P(ACHSDOC,U,4)
.I ACHSAMT>ACHSDAMT W !,?5,$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U,1)," Sorry this document exceeds your delegation of authority",!
.I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.71////"_DUZ)
.I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.72////"_DT)
.S ACHSSUM=ACHSSUM+1
.;ITSC/SET/JVK - ACHS****
.;K ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)
.I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,29)?1N.N,$P(^(0),U,30)?1N.N K ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)
.Q
W !,?5,ACHSSUM," DOCUMENTS APPROVED",! H 2
G END
;
ASK ;
S ACHSDONE=""
W !!,?10,"Answering YES will remove the items you do not want approved"
W !?10,"from the viewing list and approve all others.",!
W !?10,"Answering NO will remove the items you already selected"
W !?10,"from the viewing list and allow you to remove additional items.",!
W !?10,"If you do not want to approve anything select all the items or"
W !?10,"enter ^. This approves nothing.",!!
S ACHSDONE=$$DIR^XBDIR("Y","ARE YOU DONE","N","","Enter Y or N.",1)
I $D(DUOUT)!$D(DTOUT) D END Q
I 'ACHSDONE D VIEWR^XBLM("PRINT^ACHSSIG2"),RMITMS,ASK Q
I ACHSDONE,ACHSQUE'["0" D VIEWR^XBLM("LOOP3^ACHSSIG2") Q
HDR ;
S ACHSPG=ACHSPG+1
W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!
W ACHSTIME,!,ACHST1
W !!,"ITEM NO.",?9,"PO No.",?25,"Vendor",?50,"Obligation Amt",!,$$REPEAT^XLFSTR("=",79),!
Q
END ;
D EN^XBVK("VALM")
K DIC,DIQ,X1,ACHSDIEN,ACHSAU,ACHSANS,ACHSVAL,ACHSDOC,ACHSTMP(DUZ(2)),ACHSLST,ACHSTYPV,ACHSADT,ACHSTST,COUNT,ACHSSIG,ACHSTYP
D ^%ZISC
Q
ACHSSIG2 ;IHS/ITSC/JVK-STAMP ELECTRONIC SIGNATURE OF AUTHORIZING OFC. ON PO [ 01/11/2005 7:33 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,9,12**;JUNE 11,2001
+2 ;;ACHS*3.1*7-ALLOWING AUTHRIZING OFFICIAL E SIG
+3 ;;ACHS*3.1*8-FIX LIST FOR SPECIAL LOCALS
+4 ;;NEW ROUTINE CALLED FROM ACHS E-SIG MENU OPTION
+5 ;;3.1 8.23.04 IHS/ITSC/FCJ LOOP WAS NOT PICKING UP DOCUMENTS IF TYPE 1
+6 ; DID NOT EXIST
+7 ;
LOOK ;EP
+1 SET ACHSANS=""
+2 IF '$DATA(^ACHSF("EAQ",DUZ(2)))
Begin DoDot:1
+3 WRITE !,"There are no documents in the Queue!"
+4 DO RTRN^ACHS
End DoDot:1
QUIT
+5 SET ACHSIO=IO
+6 KILL X2,X3
+7 ;
START ;
+1 DO BM^ACHS
+2 SET ACHSFC=$$FC^ACHS(DUZ(2))
+3 SET COUNT=0
+4 SET ACHSQUIT=0
+5 SET ACHSMULT=$PIECE(^ACHSESIG(DUZ(2),0),U,2)
+6 IF 'ACHSMULT
WRITE !!!,?5,"YOUR SITE PARAMETERS INDICATE THIS IS NOT A MULTIPLE SIGNATURE SITE.",!,?5,"THIS OPTION IS NOT AVAILABLE FOR USE."
HANG 3
DO END
QUIT
+7 DO CHECK
+8 IF ACHSQUIT
GOTO END
+9 ;
LOOP1 ;--LOOP THRU QUEUE ARRAY FOR DOCUMENTS WAITING --
+1 ;ITSC/SET/JVK ACHS**
+2 SET ACHSGO=0
+3 FOR ACHSTYPV=1,3,2
DO LOOP2
IF $DATA(DUOUT)!ACHSQUIT
QUIT
+4 ;
+5 IF ACHSGO>0
IF ACHSSIG'=""
GOTO A
+6 ;
+7 ;ITSC/SET/JVK ACHS*3.1*12
+8 ;I 'ACHSGO W !,?5,"No Documents Pending for your Signature.",! H 2 G END
+9 IF ACHSGO'>0
WRITE !,?5,"No Documents Pending for your Signature.",!
HANG 2
GOTO END
+10 ;
+11 IF $DATA(DUOUT)!$DATA(DTOUT)
DO END
QUIT
+12 ;
LOOP2 ;--SECOND LEVEL OF QUEUE ARRAY SET UP ACHSTMP ARRAY--
+1 ;8.23.04 IHS/ITSC/FCJ TEST FOR DOC TYPE
IF '$DATA(^ACHSF("EAQ",DUZ(2),ACHSTYPV))
QUIT
+2 SET ACHSDIEN=""
+3 SET ACHSFLG=""
+4 FOR
SET ACHSDIEN=$ORDER(^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN))
IF +ACHSDIEN=0!$DATA(DUOUT)
QUIT
Begin DoDot:1
+5 SET ACHSDOC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
+6 SET ACHSTST1=$PIECE(ACHSDOC,U,24)
+7 SET ACHSTST2=$PIECE(ACHSDOC,U,29)
+8 ;TEST FOR ORDER AND AUTHROIZING NOT TO BE THE SAME PERSON
+9 IF ACHSTST1=DUZ
QUIT
+10 SET ACHSAMT=$PIECE(ACHSDOC,U,9)
+11 IF ACHSAMT>ACHSDAMT
QUIT
+12 IF ACHSTST2=""
SET COUNT=COUNT+1
SET ACHSTMP(DUZ(2),COUNT)=ACHSDIEN_U_ACHSAMT
SET ACHSFLG=1
+13 SET ACHSGO=COUNT
End DoDot:1
+14 QUIT
+15 ;
A ;--SET UP LIST MANAGER--
+1 DO VIEWR^XBLM("PRINT^ACHSSIG2")
+2 DO STAMP
+3 QUIT
+4 ;
PRINT ;
+1 DO FC^ACHSUF
+2 DO BRPT^ACHSFU
+3 SET ACHST1=$$C^XBFUNC("Purchase Orders to be Approved",80)
+4 DO HDR
+5 SET X3=0
+6 SET COUNT=""
+7 FOR
SET COUNT=$ORDER(ACHSTMP(DUZ(2),COUNT))
IF COUNT'?1N.N
QUIT
Begin DoDot:1
+8 SET ACHSDOC=^ACHSF(DUZ(2),"D",$PIECE(ACHSTMP(DUZ(2),COUNT),U),0)
+9 SET ACHSTYP=$PIECE(ACHSDOC,U,4)
+10 SET ACHSLST=$SELECT(ACHSTYP=1:"Hospital",ACHSTYP=3:"Outpatient",ACHSTYP=2:"Dental",1:"")
+11 DO LIST
End DoDot:1
+12 QUIT
+13 ;
CHECK ;--IS THE USER AUTHORIZED IN THE CHS E-SIG FILE--
+1 SET ACHSAU=""
+2 SET ACHSAU=$ORDER(^ACHSESIG(DUZ(2),1,"B",DUZ,ACHSAU))
+3 IF ACHSAU
Begin DoDot:1
+4 KILL DIC,DIQ
+5 SET DIC=9002080.1
SET DR=".01;1"
SET DA=DUZ(2)
+6 SET DR(9002080.11)="1:2:3"
SET DA(9002080.11)=ACHSAU
SET DIQ="ACHSVAL"
DO EN^DIQ1
+7 SET ACHSDAMT=$PIECE($GET(ACHSVAL(9002080.11,ACHSAU,1)),U)
+8 SET ACHSADT=$PIECE($GET(ACHSVAL(9002080.11,ACHSAU,2)),U)
+9 SET ACHSIADT=$PIECE($GET(ACHSVAL(9002080.11,ACHSAU,3)),U)
+10 ;ORDERING OFFICIAL
SET ACHSIGO=$PIECE($GET(ACHSVAL(9002090.11,ACHSAU,4)),U)
+11 ;AUTHORIZING OFFICAL
SET ACHSIGA=$PIECE($GET(ACHSVAL(9002090.11,ACHSAU,5)),U)
+12 QUIT
End DoDot:1
+13 DO SIG^XUSESIG
+14 SET ACHSSIG=X1
+15 IF 'ACHSAU
WRITE !,"You are not authorized in the CHS E-SIG file.",!
HANG 2
SET ACHSQUIT=1
QUIT
+16 IF ACHSIGA["NO"
IF ACHSIGA=""
WRITE !,"You are not an authorized Authorizing Official.",!
HANG 2
SET ACHSQUIT=1
+17 QUIT
STAMP ;--ASK IF YOU WANT ALL OR REMOVE ITEMS FROM LIST OF SET--
+1 IF ACHSSIG'=""
SET ACHSANS=$$DIR^XBDIR("Y","Do you want ALL documents stamped with your Electronic signature ","N","","","",1)
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
DO END
QUIT
+3 IF ACHSANS
DO LOOP3
DO END
QUIT
+4 IF 'ACHSANS
DO RMITMS
DO ASK
+5 QUIT
LIST ;--LIST ONLY THOSE PO W/OUT SIG IN FILE--
+1 ;Order No
WRITE !,COUNT,?9,$PIECE(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$PIECE(ACHSDOC,U,1)
+2 ;Vendor
WRITE ?25,$PIECE(^AUTTVNDR($PIECE(ACHSDOC,U,8),0),U)
+3 ;Total Amount Obligated
WRITE ?55,$FNUMBER($PIECE(ACHSDOC,U,9),",",2)
+4 ;W !,?9,"CAN-OCC-SCC: ",$P(^ACHS(2,$P(ACHSDOC,U,6),0),U),"-",$P(^ACHSOCC($P(ACHSDOC,U,7),0),U),"-",$P(^ACHS(3,DUZ(2),1,$P(ACHSDOC,U,10),0),U),?50,ACHSLST ;CAN & Obj Class
+5 ;CAN & Obj Class
WRITE !,?9,"CAN-OCC-SCC: ",$PIECE(^ACHS(2,$PIECE(ACHSDOC,U,6),0),U),"-",$PIECE(^ACHSOCC($PIECE(ACHSDOC,U,10),0),U),"-",$PIECE(^ACHS(3,DUZ(2),1,$PIECE(ACHSDOC,U,7),0),U),?50,ACHSLST
+6 ;ITSC/SET/JVK 2-18-2004
+7 ;W:$P(ACHSDOC,U,3)'=1 !,?9,$P(^DPT($P(ACHSDOC,U,22),0),U),! ;Patient
+8 ;Patient
IF $PIECE(ACHSDOC,U,3)=0
WRITE !,?9,$PIECE(^DPT($PIECE(ACHSDOC,U,22),0),U),!
+9 IF $PIECE(ACHSDOC,U,3)
WRITE !,?9,"--Blanket Order/Special Local--",!
+10 QUIT
RMITMS ;--REMOVE THE ITEM FROM THE SET--
+1 SET ACHSQUE=$$DIR^XBDIR("L^0:1000","Select the ITEM NO. that you DO NOT want your Electronic signature applied to ","","Enter zero for none.","","",2)
+2 IF ACHSQUE["^"
GOTO END
QUIT
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO ASK
+4 ;I Y'=0,'$D(ACHSTMP(DUZ(2),Y)) D RMITMS ;TEST FOR NUMBERS ALREADY GONE
+5 IF Y=0
QUIT
+6 SET ACHSITM=0
+7 FOR ACHSI=1:1
IF ACHSITM=""
QUIT
Begin DoDot:1
+8 SET ACHSITM=$PIECE(Y,",",ACHSI)
+9 IF ACHSITM=""
QUIT
+10 IF ACHSITM=0
QUIT
+11 IF '$DATA(ACHSTMP(DUZ(2),ACHSITM))
QUIT
+12 KILL ACHSTMP(DUZ(2),ACHSITM)
+13 QUIT
End DoDot:1
+14 QUIT
LOOP3 ;--STUFF THE USER AND DATE OF ALL AUTHORIZED--
+1 SET COUNT=""
+2 SET ACHSSUM=0
+3 FOR
SET COUNT=$ORDER(ACHSTMP(DUZ(2),COUNT))
IF COUNT'?1N.N
QUIT
Begin DoDot:1
+4 SET ACHSDOC=^ACHSF(DUZ(2),"D",$PIECE(ACHSTMP(DUZ(2),COUNT),U),0)
+5 SET ACHSDIEN=$PIECE(ACHSTMP(DUZ(2),COUNT),U)
+6 ;DOCUMENT AMOUNT
SET ACHSAMT=$PIECE(ACHSTMP(DUZ(2),COUNT),U,2)
+7 SET ACHSTYPV=$PIECE(ACHSDOC,U,4)
+8 IF ACHSAMT>ACHSDAMT
WRITE !,?5,$PIECE(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$PIECE(ACHSDOC,U,1)," Sorry this document exceeds your delegation of authority",!
+9 IF ACHSAMT<ACHSDAMT+1
IF 'ACHSIADT
IF '$$DIE^ACHS("13.71////"_DUZ)
+10 IF ACHSAMT<ACHSDAMT+1
IF 'ACHSIADT
IF '$$DIE^ACHS("13.72////"_DT)
+11 SET ACHSSUM=ACHSSUM+1
+12 ;ITSC/SET/JVK - ACHS****
+13 ;K ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)
+14 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,29)?1N.N
IF $PIECE(^(0),U,30)?1N.N
KILL ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)
+15 QUIT
End DoDot:1
+16 WRITE !,?5,ACHSSUM," DOCUMENTS APPROVED",!
HANG 2
+17 GOTO END
+18 ;
ASK ;
+1 SET ACHSDONE=""
+2 WRITE !!,?10,"Answering YES will remove the items you do not want approved"
+3 WRITE !?10,"from the viewing list and approve all others.",!
+4 WRITE !?10,"Answering NO will remove the items you already selected"
+5 WRITE !?10,"from the viewing list and allow you to remove additional items.",!
+6 WRITE !?10,"If you do not want to approve anything select all the items or"
+7 WRITE !?10,"enter ^. This approves nothing.",!!
+8 SET ACHSDONE=$$DIR^XBDIR("Y","ARE YOU DONE","N","","Enter Y or N.",1)
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
DO END
QUIT
+10 IF 'ACHSDONE
DO VIEWR^XBLM("PRINT^ACHSSIG2")
DO RMITMS
DO ASK
QUIT
+11 IF ACHSDONE
IF ACHSQUE'["0"
DO VIEWR^XBLM("LOOP3^ACHSSIG2")
QUIT
HDR ;
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!
+3 WRITE ACHSTIME,!,ACHST1
+4 WRITE !!,"ITEM NO.",?9,"PO No.",?25,"Vendor",?50,"Obligation Amt",!,$$REPEAT^XLFSTR("=",79),!
+5 QUIT
END ;
+1 DO EN^XBVK("VALM")
+2 KILL DIC,DIQ,X1,ACHSDIEN,ACHSAU,ACHSANS,ACHSVAL,ACHSDOC,ACHSTMP(DUZ(2)),ACHSLST,ACHSTYPV,ACHSADT,ACHSTST,COUNT,ACHSSIG,ACHSTYP
+3 DO ^%ZISC
+4 QUIT
