Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSSIG1

ACHSSIG1.m

Go to the documentation of this file. 
  1. 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 
  1.  ;;ACHS*3.1*7- E-SIG ORDERING OFFICIAL
  1.  ;;ACHS*3.1*8- FIX LIST LABEL FOR SUPPLEMENTS
  1.  ;CALLED FROM ACHS E-SIG OPTION
  1.  ;;3.1 8.23.04 IHS/ITSC/FCJ LOOP WAS NOT PICKING UP DOCUMENTS IF TYPE 1 
  1.  ;     DID NOT EXIST
  1.  ;;10/1/04 ITSC/SET/JVK FIX ACHSGO VALUE
  1.  ;
  1. LOOK ;EP
  1.  S ACHSANS=""
  1.  I '$D(^ACHSF("EQ",DUZ(2))) D  Q
  1.  . W !,"There are no documents in the Queue!"
  1.  . D RTRN^ACHS
  1.  S ACHSIO=IO
  1.  K X2,X3
  1.  ;
  1. START ;
  1.  D BM^ACHS
  1.  S ACHSFC=$$FC^ACHS(DUZ(2))
  1.  S COUNT=0
  1.  S ACHSQUIT=0
  1.  D CHECK
  1.  I ACHSQUIT G END
  1.  ;
  1. LOOP1 ;--LOOP THRU QUEUE ARRAY FOR DOCUMENTS WAITING TO BE PRINTED--
  1.  ;ITSC/SET/JVK LINE BELOW -ACHS*3.1*12
  1.  S ACHSGO=0
  1.  F ACHSTYPV=1,3,2  D LOOP2 Q:$D(DUOUT)!ACHSQUIT
  1.  ;
  1.  I ACHSGO>0,ACHSSIG'=""  G A
  1.  ;
  1.  ;ITSC/SET/JVK LINE BELOW -ACHS**
  1.  ;I 'ACHSGO W !,?5,"No Documents Pending for Signature.",! H 2 G END
  1.  I ACHSGO'>0 W !,?5,"No Documents Pending for Signature.",! H 2 G END
  1.  ;
  1.  I $D(DUOUT)!$D(DTOUT) D END Q
  1.  ;
  1. LOOP2 ;--SECOND LEVEL OF QUEUE ARRAY SET UP ACHSTMP ARRAY--
  1.  Q:'$D(^ACHSF("EQ",DUZ(2),ACHSTYPV))  ;8.23.04 IHS/ITSC/FCJ TEST FOR DOCTYPE
  1.  S ACHSDIEN=""
  1.  S ACHSFLG=""
  1.  F  S ACHSDIEN=$O(^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0!$D(DUOUT)  D
  1.  .S ACHSDOC=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
  1.  .S ACHSTST=$P(ACHSDOC,U,24)
  1.  .S ACHSAMT=$P(ACHSDOC,U,9)
  1.  .I ACHSAMT>ACHSDAMT Q
  1.  .I ACHSTST="" S COUNT=COUNT+1,ACHSTMP(DUZ(2),COUNT)=ACHSDIEN_U_ACHSAMT,ACHSFLG=1
  1.  .S ACHSGO=COUNT
  1.  Q
  1.  ;
  1. A ;--SET UP LIST MANAGER--
  1.  D VIEWR^XBLM("PRINT^ACHSSIG1")
  1.  D STAMP
  1.  Q
  1.  ;
  1. PRINT ;
  1.  D FC^ACHSUF
  1.  D BRPT^ACHSFU
  1.  S ACHST1=$$C^XBFUNC("Purchase Orders to be Approved",80)
  1.  D HDR
  1.  S X3=0
  1.  S COUNT=""
  1.  F  S COUNT=$O(ACHSTMP(DUZ(2),COUNT)) Q:COUNT'?1N.N  D
  1.  .S ACHSDOC=^ACHSF(DUZ(2),"D",$P(ACHSTMP(DUZ(2),COUNT),U),0)
  1.  .S ACHSTYP=$P(ACHSDOC,U,4)
  1.  .S ACHSLST=$S(ACHSTYP=1:"Hospital",ACHSTYP=3:"Outpatient",ACHSTYP=2:"Dental",1:"")
  1.  .D LIST
  1.  Q
  1.  ; 
  1. CHECK ;--IS THE USER AUTHORIZED IN THE CHS E-SIG FILE--
  1.  S ACHSAU=""
  1.  S ACHSAU=$O(^ACHSESIG(DUZ(2),1,"B",DUZ,ACHSAU))
  1.  I ACHSAU D
  1.  .K DIC,DIQ
  1.  .S DIC=9002080.1,DR=".01;1",DA=DUZ(2)
  1.  .S DR(9002080.11)="1:5",DA(9002080.11)=ACHSAU,DIQ="ACHSVAL" D EN^DIQ1
  1.  .S ACHSDAMT=$P($G(ACHSVAL(9002080.11,ACHSAU,1)),U)
  1.  .S ACHSADT=$P($G(ACHSVAL(9002080.11,ACHSAU,2)),U)
  1.  .S ACHSIADT=$P($G(ACHSVAL(9002080.11,ACHSAU,3)),U)
  1.  .S ACHSIGO=$P($G(ACHSVAL(9002080.11,ACHSAU,4)),U)
  1.  .S ACHSIGA=$P($G(ACHSVAL(9002080.11,ACHSAU,5)),U)
  1.  .Q
  1.  D SIG^XUSESIG
  1.  S ACHSSIG=X1
  1.  I 'ACHSAU W !,"You are not authorized in the CHS E-SIG file.",! H 2 S ACHSQUIT=1 Q
  1.  I ACHSIADT'="" W !,"You are currently not authorized in the CHS E-SIG file.",! H 2 S ACHSQUIT=1 Q
  1.  I ACHSIGO["NO",ACHSIGO="" W !,"You are not an authorized Ordering Official.",! H 2 S ACHSQUIT=1
  1.  Q
  1. STAMP ;--ASK IF YOU WANT ALL OR REMOVE ITEMS FROM LIST OF SET--
  1.  I ACHSSIG'="" S ACHSANS=$$DIR^XBDIR("Y","Do you want ALL documents stamped with your Electronic signature ","N","","","",1)
  1.  I $D(DUOUT)!$D(DTOUT) D END Q
  1.  I ACHSANS D LOOP3,END Q
  1.  I 'ACHSANS D RMITMS,ASK
  1.  Q
  1. LIST ;--LIST ONLY THOSE PO W/OUT SIG IN FILE--
  1.  W !,COUNT,?9,$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U,1) ;Order No
  1.  W ?25,$P(^AUTTVNDR($P(ACHSDOC,U,8),0),U) ;Vendor
  1.  W ?55,$FN($P(ACHSDOC,U,9),",",2) ;Total Amount Obligated
  1.  ;ACHS*3.1*19 ADDED $G TO NEXT LINE
  1.  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
  1.  ;ITSC/SET/JVK 1/20/04 ACHS*3.1*8
  1.  ;W:$P(ACHSDOC,U,3)'=1 !,?9,$P(^DPT($P(ACHSDOC,U,22),0),U),! ;Patient
  1.  I $P(ACHSDOC,U,3)=0 W !,?9,$P(^DPT($P(ACHSDOC,U,22),0),U),! ;Patient
  1.  I $P(ACHSDOC,U,3) W !,?9,"--Blanket Order/Special Local--",!
  1.  Q
  1. RMITMS ;--REMOVE THE ITEM FROM THE SET--
  1.  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)
  1.  I ACHSQUE["^" G END Q
  1.  I $D(DUOUT)!$D(DTOUT) G ASK
  1.  ;I Y'=0,'$D(ACHSTMP(DUZ(2),Y)) D RMITMS         ;TEST FOR NUMBERS ALREADY GONE
  1.  ;I Y=0 Q
  1.  S ACHSITM=0
  1.  F ACHSI=1:1 Q:ACHSITM=""  D
  1.  .S ACHSITM=$P(Y,",",ACHSI)
  1.  .Q:ACHSITM=""
  1.  .Q:ACHSITM=0
  1.  .Q:'$D(ACHSTMP(DUZ(2),ACHSITM))
  1.  .K ACHSTMP(DUZ(2),ACHSITM)
  1.  .Q
  1.  Q
  1. LOOP3 ;--STUFF THE USER AND DATE OF ALL AUTHORIZED--
  1.  S COUNT=""
  1.  S ACHSSUM=0
  1.  F  S COUNT=$O(ACHSTMP(DUZ(2),COUNT)) Q:COUNT'?1N.N  D
  1.  .S ACHSDOC=^ACHSF(DUZ(2),"D",$P(ACHSTMP(DUZ(2),COUNT),U),0)
  1.  .S ACHSDIEN=$P(ACHSTMP(DUZ(2),COUNT),U)
  1.  .S ACHSAMT=$P(ACHSTMP(DUZ(2),COUNT),U,2) ;DOCUMENT AMOUNT
  1.  .S ACHSTYPV=$P(ACHSDOC,U,4)
  1.  .I ACHSAMT>ACHSDAMT W !,?5,$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U,1)," Sorry this document exceeds your delegation of authority",!
  1.  .;ITSC/SET/JVK ADD THE +1 FOR LIMIT LEVEL INCLUSIVE OF VALUE
  1.  .I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.69////"_DUZ)
  1.  .I ACHSAMT<ACHSDAMT+1,'ACHSIADT,'$$DIE^ACHS("13.7////"_DT)
  1.  .S ACHSSUM=ACHSSUM+1
  1.  .;IF THIS IS MULTI SIG PUT THE VALUE IN THE ACHSF("EAQ" GLOBAL
  1.  .I $P(^ACHSESIG(DUZ(2),0),U,2)=1 S ^ACHSF("EAQ",DUZ(2),ACHSTYPV,ACHSDIEN)=""
  1.  .;ITSC/SET/JVK 11-18-04 IF LOCK FAILED 
  1.  .;K ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN)
  1.  .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)
  1.  .Q
  1.  W !,?5,ACHSSUM," DOCUMENTS APPROVED",! H 2
  1.  G END
  1.  ;
  1. ASK ;
  1.  S ACHSDONE=""
  1.  W !!?10,"Answering YES will remove items you do not want approved"
  1.  W !?10,"from the viewing list and approve all others.",!
  1.  W !?10,"Answering NO will remove the items you already selected",!
  1.  W ?10,"from the viewing list and allow you to remove additioanl items.",!
  1.  W !?10,"If you do not want to approve anything select all the items or ",!
  1.  W ?10,"enter ^.  This approves nothing.",!!
  1.  S ACHSDONE=$$DIR^XBDIR("Y","ARE YOU DONE"," N","","Enter Y or N.",1)
  1.  I $D(DUOUT)!$D(DTOUT) D END Q
  1.  I 'ACHSDONE D VIEWR^XBLM("PRINT^ACHSSIG1"),RMITMS,ASK Q
  1.  I ACHSDONE D VIEWR^XBLM("LOOP3^ACHSSIG1") Q
  1. HDR ;
  1.  S ACHSPG=ACHSPG+1
  1.  W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("***  CONTRACT HEALTH MANAGEMENT SYSTEM   ***",80),!!,ACHSLOC,!
  1.  W ACHSTIME,!,ACHST1
  1.  W !!,"ITEM NO.",?9,"PO No.",?25,"Vendor",?50,"Obligation Amt",!,$$REPEAT^XLFSTR("=",79),!
  1.  Q
  1. END ;
  1.  D EN^XBVK("VALM")
  1.  K DIC,DIQ,X1,ACHSDIEN,ACHSAU,ACHSANS,ACHSVAL,ACHSDOC,ACHSTMP(DUZ(2)),ACHSLST,ACHSTYPV,ACHSADT,ACHSTST,COUNT,ACHSSIG,ACHSTYP
  1.  D ^%ZISC
  1.  Q