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

ACHSRP.m

Go to the documentation of this file. 
  1. ACHSRP ; IHS/ITSC/PMF - PRINT CHS FORMS ; 27 Jul 2010  11:56 AM
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**2,11,13,16,19,25**;JUN 11, 2001;Build 43
  1.  ;;ACHS*3.1*2; check for POs for the user's facility
  1.  ;3.1*11; 9.16.04 IHS/ITSC/FCJ TEST FOR E-SIG ADDED
  1.  ;ACHS*3.1*13 12/11/07 IHS/OIT/FCJ FX NAKED REF
  1.  ;ACHS*3.1*16 10/26/2009 IHS.OIT.FCJ COPY REQUEST FOR ZUNI
  1.  ;
  1.  ;CALLED FROM OPTION ACHSRP^Print Documents (IEN=6105)
  1. Z ;
  1.  ;IF ACHSRPNT IS NULL THEN THIS RTN HAS BEEN CALLED BY ACHSRR AT TAG B1
  1.  ;TO RE-PRINT FORM
  1.  K A,B,C,D,E,F,^TMP("ACHSRR",$J),ACHSRPNT
  1.  S (ACHSALL,ACHSREG,C)=0
  1.  ;
  1.  ;12/26/01  pmf  check for docs under THIS facility only  ACHS*3.1*2
  1.  ;I '$D(^ACHSF("PQ")) D  Q  ; ACHS*3.1*2
  1.  I '$D(^ACHSF("PQ",DUZ(2))) D  Q  ; ACHS*3.1*2
  1.  .W !,"Documents were not found to be queued!"
  1.  .D RTRN^ACHS        ;THE PQ IS A FM X-REF THE FORM IS:
  1.  ;                   ^ACHSF("PQ",FACILITY,TYPE OF SERVICE,DOC #,TRAN #
  1.  ;                   IF THIS IS NOT THERE AND U NEED TO DO A RE-PRINT
  1.  ;                   USE RTN ACHSYPQ TO RESET THE PQ X-REF
  1.  ;
  1. A1 ;
  1.  ;DUZ(2) is saved and restored in the menu option ACTION field.?????IS IT
  1.  ;
  1. B1 ;EP.
  1.  W !
  1.  I $P(^AUTTLOC(DUZ(2),0),U,10)=202501 S ACHSCPY=4,ACHSCPY=$$DIR^ACHS("N^0:10:0","Print how many copies? ",ACHSCPY)  ;OIT.IHS.FCJ ADDED FOR ZUNI PATCH
  1.  K DTOUT,DUOUT,POP
  1.  S %ZIS="P",%ZIS("A")="Print Forms On Device: "
  1.  D ^%ZIS                       ;EXIT BY "^" POP=1
  1.  I POP D END Q                 ;EXIT OUT OF %ZIS
  1.  I $D(IO("S")) D SLV^ACHSFU    ;IF SLAVE DEV, DO OPEN & GET CLOSE PARAMS
  1.  ;
  1.  ;WHY DO WE DO THIS NEXT LINE IF DTOUT IS NOT RETURNED FROM %ZIS?????
  1.  ;D:$D(DTOUT),END,END:$D(DUOUT)&$D(ACHSRPNT),END:$D(DUOUT),Z:$D(DUOUT),END:'$D(IO),END:POP
  1.  ;
  1.  ;IS THIS NOT A RE-PRINT SET UP NEW ENTRY IN 'CHS DOCUMENT PRINTED LIST'
  1.  ;I DON'T THINK THIS IS AN APPROPRATE PLACE TO DO THIS???????
  1.  ;WILL LEAVE FOR NOW BUT NEEDS TO BE MODIFIED.
  1.  I '$D(ACHSRPNT) D
  1.  . I '$$LOCK^ACHS("^ACHS(7)","+") W !,"LOCK FAILED AT B1+13^ACHSRP"
  1.  . ;GET 0 RECORD OF 'CHS DOCUMENT PRINTED LIST' FILE
  1.  . S X=$G(^ACHS(7,0))
  1.  . S ACHS7DA=$P(X,U,3)+1   ;MANUALLY INCREMENT # ENTRIES FIELD 
  1.  . ;S ^(0)=$P(X,U,1,2)_U_ACHS7DA_U_ACHS7DA  ;PLACE INTO 0 RECORD ;ACHS*3.1*13 12/11/07 IHS/OIT/FCJ FX NAKED REF
  1.  . S ^ACHS(7,0)=$P(X,U,1,2)_U_ACHS7DA_U_ACHS7DA  ;PLACE INTO 0 RECORD ;ACHS*3.1*13 12/11/07
  1.  . S ^ACHS(7,ACHS7DA,0)=IO_U_DT,^ACHS(7,ACHS7DA,"D",0)="^9002067.01^^",^ACHS(7,"CZ",9999999-DT,ACHS7DA)="",^ACHS(7,"B",IO,ACHS7DA)=""
  1.  . I '$$LOCK^ACHS("^ACHS(7)","-")
  1.  ;
  1.  ;
  1.  ;LOOP THROUGH THE PQ X-REF BASED ON THE TYPE OF SERVICE
  1.  F ACHSTYPV=1,3,2 S ACHSACF=$S(ACHSTYPV=1:"Hospital Service",ACHSTYPV=3:"Outpatient Service",ACHSTYPV=2:"Dental Service",1:"") D  I $D(DUOUT) D END Q
  1.  .D SB1
  1.  K DIR
  1.  ;
  1.  ;ACHS*3.1*11; 9.16.04 IHS/ITSC/FCJ DISPLAY MESG FOR UNSIGNED DOCS
  1.  ;I $D(ACHSEFL),$P(ACHSEFL,U,3)>0 W !!!,"**** ",$P(ACHSEFL,U,3)," Documents were NOT printed, because missing E-Signature ****"
  1.  I ($D(^ACHSF("EQ",DUZ(2)))!$D(ACHSF("EAQ"),DUZ(2))) W !!!,"****  Some Documents were NOT printed, because missing E-Signature ****" ;ACHS*3.1*25
  1.  I $G(ACHSREG) F  W !!!!,*7 S DIR(0)="E",DIR("A",1)="Put Regular Paper Back In The Printer ",DIR("A")="And Press RETURN",DIR("T")=10 D ^DIR Q:Y=1
  1.  D END
  1.  Q
  1.  ; 
  1. SB1 ;
  1.  I '$D(ACHSRPNT),'$D(^ACHSF("PQ",DUZ(2),ACHSTYPV)) D S18 Q   ;DOCS NOT QUED
  1.  ;
  1.  I $D(ACHSRPNT),'$D(^TMP("ACHSRR",$J)) D S18 Q    ;DATA HAS NOT BEEN PROCESSED QUIT
  1.  ;
  1.  Q:'$$DIR^XBDIR("Y","Print "_ACHSACF_" Forms ","YES","","","",2)
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  S ACHSREG=1      ;
  1.  I $D(^ACHSESIG(DUZ(2))) S ACHSEFL=$P(^ACHSESIG(DUZ(2),0),U,2,3) ;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ TEST FOR E-SIG ADDED LINE
  1.  D ^ACHSRP1       ;GO GET THE DATA AND PRINT THE FORM
  1.  ;
  1.  Q
  1.  ;
  1. S18 ;
  1.  W !!,"***   No ",ACHSACF," Forms Queued   ***"
  1.  I $$DIR^XBDIR("E","Press RETURN...")
  1. S19 ;
  1.  Q
  1.  ;
  1. HDR ;
  1.  S X="DOCUMENT PRINTING"
  1.  D SHDR^ACHS
  1.  K ACHSTYP,ACHSPROV,ACHSCONP,ACHSCAN,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF
  1.  Q
  1.  ;
  1.  ;LETS CLEAN UP AND GET OUTA HERE  ;DOES THIS REALLY RESET DUZ AND FAC VARS?????
  1. END ;
  1.  K B,DFN
  1.  I $G(ACHSDUZ2) S ^TMP("ACHSDUZ2",$J)=ACHSDUZ2
  1.  D ^%ZISC            ;CLOSE ALL DEVICES
  1.  D EN^XBVK("ACHS")   ;KILL VARS IN ACHS NAMESPACE
  1.  D ^ACHSVAR         ;RESET ACHS VARIABLES
  1.  I $G(^TMP("ACHSDUZ2",$J)) S ACHSDUZ2=$G(^TMP("ACHSDUZ2",$J)) K ^($J)
  1.  K DIR  ;achs*3.1*19
  1.  Q
  1.  ;