ACHSSIG1 ;IHS/ITSC/JVK -STAMP ELECTRONIC SIGNATURE OF ORDERING OFC. ON PO [ 02/15/2005 7:59 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,12,19**;JUNE 11,2001
;;ACHS*3.1*7- E-SIG ORDERING OFFICIAL
;;ACHS*3.1*8- FIX LIST LABEL FOR SUPPLEMENTS
;CALLED FROM ACHS E-SIG OPTION
;;3.1 8.23.04 IHS/ITSC/FCJ LOOP WAS NOT PICKING UP DOCUMENTS IF TYPE 1
; DID NOT EXIST
;;10/1/04 ITSC/SET/JVK FIX ACHSGO VALUE
;
LOOK ;EP
S ACHSANS=""
I '$D(^ACHSF("EQ",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
D CHECK
I ACHSQUIT G END
;
LOOP1 ;--LOOP THRU QUEUE ARRAY FOR DOCUMENTS WAITING TO BE PRINTED--
;ITSC/SET/JVK LINE BELOW -ACHS*3.1*12
S ACHSGO=0
F ACHSTYPV=1,3,2 D LOOP2 Q:$D(DUOUT)!ACHSQUIT
;
I ACHSGO>0,ACHSSIG'="" G A
;
;ITSC/SET/JVK LINE BELOW -ACHS**
;I 'ACHSGO W !,?5,"No Documents Pending for Signature.",! H 2 G END
I ACHSGO'>0 W !,?5,"No Documents Pending for 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("EQ",DUZ(2),ACHSTYPV)) ;8.23.04 IHS/ITSC/FCJ TEST FOR DOCTYPE
S ACHSDIEN=""
S ACHSFLG=""
F S ACHSDIEN=$O(^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0!$D(DUOUT) D
.S ACHSDOC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
.S ACHSTST=$P(ACHSDOC,U,24)
.S ACHSAMT=$P(ACHSDOC,U,9)
.I ACHSAMT>ACHSDAMT Q
.I ACHSTST="" 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^ACHSSIG1")
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:5",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(9002080.11,ACHSAU,4)),U)
.S ACHSIGA=$P($G(ACHSVAL(9002080.11,ACHSAU,5)),U)
.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 ACHSIADT'="" W !,"You are currently not authorized in the CHS E-SIG file.",! H 2 S ACHSQUIT=1 Q
I ACHSIGO["NO",ACHSIGO="" W !,"You are not an authorized Ordering 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
;ACHS*3.1*19 ADDED $G TO NEXT LINE
W !,?9,"CAN-OCC-SCC: ",$P(^ACHS(2,$P(ACHSDOC,U,6),0),U),"-",$P($G(^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 1/20/04 ACHS*3.1*8
;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^1: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",!
.;ITSC/SET/JVK ADD THE +1 FOR LIMIT LEVEL INCLUSIVE OF VALUE
.I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.69////"_DUZ)
.I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.7////"_DT)
.S ACHSSUM=ACHSSUM+1
.;IF THIS IS MULTI SIG PUT THE VALUE IN THE ACHSF("EAQ" GLOBAL
.I $P(^ACHSESIG(DUZ(2),0),U,2)=1 S ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)=""
.;ITSC/SET/JVK 11-18-04 IF LOCK FAILED
.;K ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)
.I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)?1N.N,$P(^(0),U,28)?1N.N K ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)
.Q
W !,?5,ACHSSUM," DOCUMENTS APPROVED",! H 2
G END
;
ASK ;
S ACHSDONE=""
W !!?10,"Answering YES will remove 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 additioanl 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^ACHSSIG1"),RMITMS,ASK Q
I ACHSDONE D VIEWR^XBLM("LOOP3^ACHSSIG1") 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
ACHSSIG1 ;IHS/ITSC/JVK -STAMP ELECTRONIC SIGNATURE OF ORDERING OFC. ON PO [ 02/15/2005 7:59 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,12,19**;JUNE 11,2001
+2 ;;ACHS*3.1*7- E-SIG ORDERING OFFICIAL
+3 ;;ACHS*3.1*8- FIX LIST LABEL FOR SUPPLEMENTS
+4 ;CALLED FROM ACHS E-SIG OPTION
+5 ;;3.1 8.23.04 IHS/ITSC/FCJ LOOP WAS NOT PICKING UP DOCUMENTS IF TYPE 1
+6 ; DID NOT EXIST
+7 ;;10/1/04 ITSC/SET/JVK FIX ACHSGO VALUE
+8 ;
LOOK ;EP
+1 SET ACHSANS=""
+2 IF '$DATA(^ACHSF("EQ",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 DO CHECK
+6 IF ACHSQUIT
GOTO END
+7 ;
LOOP1 ;--LOOP THRU QUEUE ARRAY FOR DOCUMENTS WAITING TO BE PRINTED--
+1 ;ITSC/SET/JVK LINE BELOW -ACHS*3.1*12
+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 LINE BELOW -ACHS**
+8 ;I 'ACHSGO W !,?5,"No Documents Pending for Signature.",! H 2 G END
+9 IF ACHSGO'>0
WRITE !,?5,"No Documents Pending for 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 DOCTYPE
IF '$DATA(^ACHSF("EQ",DUZ(2),ACHSTYPV))
QUIT
+2 SET ACHSDIEN=""
+3 SET ACHSFLG=""
+4 FOR
SET ACHSDIEN=$ORDER(^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN))
IF +ACHSDIEN=0!$DATA(DUOUT)
QUIT
Begin DoDot:1
+5 SET ACHSDOC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
+6 SET ACHSTST=$PIECE(ACHSDOC,U,24)
+7 SET ACHSAMT=$PIECE(ACHSDOC,U,9)
+8 IF ACHSAMT>ACHSDAMT
QUIT
+9 IF ACHSTST=""
SET COUNT=COUNT+1
SET ACHSTMP(DUZ(2),COUNT)=ACHSDIEN_U_ACHSAMT
SET ACHSFLG=1
+10 SET ACHSGO=COUNT
End DoDot:1
+11 QUIT
+12 ;
A ;--SET UP LIST MANAGER--
+1 DO VIEWR^XBLM("PRINT^ACHSSIG1")
+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:5"
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 SET ACHSIGO=$PIECE($GET(ACHSVAL(9002080.11,ACHSAU,4)),U)
+11 SET ACHSIGA=$PIECE($GET(ACHSVAL(9002080.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 ACHSIADT'=""
WRITE !,"You are currently not authorized in the CHS E-SIG file.",!
HANG 2
SET ACHSQUIT=1
QUIT
+17 IF ACHSIGO["NO"
IF ACHSIGO=""
WRITE !,"You are not an authorized Ordering Official.",!
HANG 2
SET ACHSQUIT=1
+18 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 ;ACHS*3.1*19 ADDED $G TO NEXT LINE
+5 ;CAN & Obj Class
WRITE !,?9,"CAN-OCC-SCC: ",$PIECE(^ACHS(2,$PIECE(ACHSDOC,U,6),0),U),"-",$PIECE($GET(^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 1/20/04 ACHS*3.1*8
+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^1: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 ;I Y=0 Q
+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 ;ITSC/SET/JVK ADD THE +1 FOR LIMIT LEVEL INCLUSIVE OF VALUE
+10 IF ACHSAMT<ACHSDAMT+1
IF 'ACHSIADT
IF '$$DIE^ACHS("13.69////"_DUZ)
+11 IF ACHSAMT<ACHSDAMT+1
IF 'ACHSIADT
IF '$$DIE^ACHS("13.7////"_DT)
+12 SET ACHSSUM=ACHSSUM+1
+13 ;IF THIS IS MULTI SIG PUT THE VALUE IN THE ACHSF("EAQ" GLOBAL
+14 IF $PIECE(^ACHSESIG(DUZ(2),0),U,2)=1
SET ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)=""
+15 ;ITSC/SET/JVK 11-18-04 IF LOCK FAILED
+16 ;K ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)
+17 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)?1N.N
IF $PIECE(^(0),U,28)?1N.N
KILL ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)
+18 QUIT
End DoDot:1
+19 WRITE !,?5,ACHSSUM," DOCUMENTS APPROVED",!
HANG 2
+20 GOTO END
+21 ;
ASK ;
+1 SET ACHSDONE=""
+2 WRITE !!?10,"Answering YES will remove 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 additioanl 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^ACHSSIG1")
DO RMITMS
DO ASK
QUIT
+11 IF ACHSDONE
DO VIEWR^XBLM("LOOP3^ACHSSIG1")
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
