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

ACHSODQ.m

Go to the documentation of this file. 
  1. ACHSODQ ; IHS/ITSC/PMF - DCR REPORT ;     [ 10/31/2003  11:51 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6**;JUNE 11, 2001
  1.  ;ACHS*3.1*6  3.27.03 IHS/SET/FCJ $O WAS SKIPPING FIRST DAY OF REPORT
  1.  ;
  1.  ;this prints out a report on the Document Control Register
  1.  ;of your choice.  Reprints and multiple copies are allowed.
  1.  ;
  1.  ;IMPORTANT!! This is not just a report.  Printing an open
  1.  ;DCR CLOSES it.
  1.  ;
  1.  K X2,X3
  1. START ;
  1.  S ACHSASK=0
  1.  D ^ACHSUF
  1.  I $D(ACHSERR),ACHSERR=1 G END
  1.  ;
  1. REPRINT ;
  1.  W !!,"Do You Wish To Re-Print A Prior Register ? NO// "
  1.  D READ^ACHSFU
  1.  G END:$D(DUOUT)
  1.  I Y?1"?".E D YN^ACHS,NOQUE G REPRINT
  1.  I Y=""!(Y?1"N".E) G END:ACHSASK,DCR
  1.  I Y'?1"Y".E W *7,"  ??" G REPRINT
  1. RE2 ;
  1.  W !!,"Re-Print Register Number: "
  1.  D READ^ACHSFU
  1.  G END:$D(DTOUT),REPRINT:$D(DUOUT),RE3:'(Y?1"?".E)
  1.  W !,"  Enter The Register Number With The Fiscal Year Code And",!,"  Specific Register Number Separated By A Dash (e.g.  9-012)."
  1.  W !,"  If You Wish To See A List Of Register Numbers Enter The Fiscal Year",!,"  And A Question Mark Separated By A Dash (e.g. 6-?)."
  1.  G RE2
  1.  ;
  1. RE3 ;
  1.  G END:Y=""
  1.  S X=$E(Y,2)
  1.  I " .,/\"[X S Y=$E(Y,1)_"-"_$E(Y,3,99)
  1.  S R=$P(Y,"-",2,99),ACHSR1=$P(Y,"-",1)
  1.  I ACHSR1?1N G RE4:R="?",RE3A:R?1N.N
  1.  W *7,"  ??"
  1.  G RE2
  1.  ;
  1. RE3A ; Print multiple copies of the selected DCR.
  1.  W !!,"Enter number of copies: 1//"
  1.  D READ^ACHSFU
  1.  G RE3:$D(DTOUT),RE3:$D(DUOUT)!($E(Y)="?")
  1.  I Y="" S Y=1 S ACHSNUM=+Y G RE4
  1.  I Y'?1N.N G RE3A
  1.  S ACHSNUM=+Y
  1. RE4 ;
  1.  S ACHSX=ACHSR1
  1.  D FYCVT^ACHSFU
  1.  S ACHSACY=ACHSY
  1.  D REGHEAD
  1.  G RE2:R="?"
  1.  S Y=$$DIR^XBDIR("Y","Is This Correct","YES","","","",2)
  1.  G END:$D(DTOUT),RE2:$D(DUOUT)
  1.  G RE2:'Y
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD -1 TO ACHSBDT,$O SKIPPING FIRST DAY
  1.  ;S R=+R,ACHSACRP=R,ACHSBDT=ACHSACY-1701_$P(^ACHSF(DUZ(2),0),U,6),ACHSEDT=$P(^ACHS(9,DUZ(2),"FY",ACHSACY,"W",R,0),U,2) ;ACHS*3.1*6
  1.  S R=+R,ACHSACRP=R,ACHSBDT=ACHSACY-1701_($P(^ACHSF(DUZ(2),0),U,6)-1),ACHSEDT=$P(^ACHS(9,DUZ(2),"FY",ACHSACY,"W",R,0),U,2) ;ACHS*3.1*6
  1.  I $D(^ACHS(9,DUZ(2),"FY",ACHSACY,"W",R-1,0)) S ACHSBDT=$P(^(0),U,2)
  1. REDEV ;
  1.  W !!
  1.  S %ZIS="P"
  1.  D ^%ZIS
  1.  I POP W !!,*7,"  DCR REPRINT REQUEST CANCELLED" D HOME^%ZIS G END
  1.  K ^TMP("ACHSOD",$J,DUZ(2))
  1.  S ACHSIO=IO
  1.  S D=$H,^TMP("ACHSOD",$J,DUZ(2),0)="^ACHSODP^"_DUZ_U_Y_U_D_U_D,^("DCR",ACHSACY,0)=DUZ(2)_U_ACHSIO_U_ACHSBDT_U_ACHSEDT_U_ACHSACY_U_ACHSACRP
  1.  S ^TMP("ACHSOD",$J,DUZ(2),"DESC")="DCR "_ACHSACY_"-"_ACHSACRP_" from "_ACHSBDT_" to "_ACHSEDT
  1.  G DCR5
  1.  ;
  1. DCR ;
  1.  S ACHSACY=ACHSCFY,ACHSASK=1,R=+ACHSFYWK(DUZ(2),ACHSCFY)
  1.  I $D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",R,0)),$P(^(0),U,2)="" G DCR2
  1.  W *7,!!,"The Current Register, Number ",$E(ACHSACY,4),"-",$E("1000"+R,2,4),!,"Has Been Printed. Use The Re-Print Option If You",!,"Wish To Print This Register Again."
  1.  G REPRINT
  1.  ;
  1. DCR2 ;
  1.  D VIDEO^ACHS
  1.  F I=1:1:2 W *7,!!,"If you print this register, you will " W $G(IORVON) W "CLOSE THIS REGISTER!" W $G(IORVOFF) H 1
  1.  W !!,"Print Register Number  ",$E(ACHSACY,4),"-",$E(1000+R,2,4),"  ...Ok ? NO// "
  1.  D READ^ACHSFU
  1.  G END:$D(DTOUT),START:$D(DUOUT),REPRINT:(Y="")
  1.  I Y?1"?".E W !,"  Do You Wish To 'CLOSE' And Print This Register.",!,"  Enter 'Y' or 'N'." D NOQUE G DCR2
  1.  G REPRINT:Y=""!(Y?1"N".E)
  1.  I Y]"",Y'?1"Y".E W *7,"  ??" G DCR2
  1. DCR2A ;PRINT MULTIPLE COPIES
  1.  W !!,"Enter number of copies: 1// "
  1.  D READ^ACHSFU
  1.  G DCR2:$D(DTOUT),DCR2:$D(DUOUT)!($E(Y)="?")
  1.  I Y="" S Y=1,ACHSNUM=+Y G DCR3
  1.  I Y'?1N.N G DCR2A
  1.  S ACHSNUM=+Y
  1. DCR3 ;EP
  1.  I $D(ACHSAUTO) S %ZIS("A")="ENTER DEVICE TO PRINT DCR: "
  1.  I $D(ACHSAUTO) W !,"Closing Current Registers And Printing 'DCRs'.  Please Wait.....",!
  1.  K ^TMP("ACHSOD",$J,DUZ(2))
  1.  S ACHSIO=IO
  1.  W !!,"The following REGISTERS have been CLOSED:",!!?12,"FY",?22,"REG #",!
  1.  S ACHSDT=DT,X1=DT,X2=-1,X=DT
  1.  D:$D(ACHS("DCR")) C^%DTC
  1.  S ACHSDT=X
  1.  K X1,X2
  1.  F ACHS=0:0 S ACHS=$O(ACHSFYWK(DUZ(2),ACHS)) Q:'ACHS  D
  1.  . S ACHSXX=ACHSFYWK(DUZ(2),ACHS),$P(^ACHS(9,DUZ(2),"FY",ACHS,"W",ACHSXX,0),U,2)=ACHSDT
  1.  . S ^ACHS(9,DUZ(2),"FY",ACHS,"AR",9999999-ACHSDT,ACHSXX)=""
  1.  . W !?10,ACHS,?20,$J(ACHSXX,5)
  1.  .Q
  1.  S D=$H,^TMP("ACHSOD",$J,DUZ(2),0)="^ACHSODP^"_DUZ_U_Y_U_D_U_D
  1.  S ^TMP("ACHSOD",$J,DUZ(2),"DESC")="DCR run on "_ACHSDT
  1.  S ACHSRX=0
  1.  W !!
  1.  S %ZIS="P"
  1.  D ^%ZIS
  1.  I POP W *7,!!,"  DCR REQUEST CANCELLED",! K %ZIS D HOME^%ZIS S:$D(ACHSAUTO) ACHSERR="" Q
  1.  S ACHSIO=IO
  1. DCR4 ;
  1.  S ACHSRX=$O(ACHSFYWK(DUZ(2),ACHSRX))
  1.  G:+ACHSRX=0 DCR5
  1.  S ACHSXX=ACHSFYWK(DUZ(2),ACHSRX)
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGED 10000 TO 10001,PICK UP 1ST DAY 
  1.  ;S ACHSACRP=0,R=ACHSXX,ACHSDCR=R,ACHSEDT=ACHSDT,ACHSBDT=ACHSFYDT-10000 ;ACHS*3.1*6
  1.  S ACHSACRP=0,R=ACHSXX,ACHSDCR=R,ACHSEDT=ACHSDT,ACHSBDT=ACHSFYDT-10000 ;ACHS*3.1*6
  1.  I $D(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",R-1,0)),$P(^(0),U,2) S ACHSBDT=$P(^(0),U,2)
  1.  S ^TMP("ACHSOD",$J,DUZ(2),"DCR",ACHSRX,0)=DUZ(2)_U_ACHSIO_U_ACHSBDT_U_ACHSEDT_U_ACHSRX_U_ACHSDCR
  1.  G DCR4
  1.  ;
  1. DCR5 ;
  1.  U IO(0)
  1.  W:'$D(IO("S")) !!,"  Your DCR will begin to print in a moment."
  1.  D END,WAIT^DICD:'$D(IO("S"))
  1.  U ACHSIO
  1.  G ^ACHSODB
  1.  ;
  1. END ;
  1.  K ACHSASK,ACHSDCR,ACHSX,ACHSY,ACHSACRP,ACHSACY,IOSC,ACHSXX
  1.  Q
  1.  ;
  1. REGHEAD ;
  1.  S I=$S(R="?":0,1:R-1),E=$S(R="?":1,1:0)
  1.  W:R="?" @IOF
  1.  W !!!,"Reg #",?8,"Ending Date",!,"-----",?8,"-----------",!
  1. REGSHOW ;
  1.  S I=$O(^ACHS(9,DUZ(2),"FY",ACHSACY,"W",I)) Q:I=""  G REGSHOW:'$D(^(I,0)) S X=$P(^(0),U,2)
  1.  I I=1,X="" W !,"No Past Registers to Print"
  1.  I X W $E(ACHSACY,4),"-",$E(1000+I,2,4),"    ",$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",$E(X,4,5))," ",$J(+$E(X,6,7),2),", ",$E(X,2,3),!
  1.  G REGSHOW:E
  1.  Q
  1.  ;
  1. NOQUE ;
  1.  W !,"NOTE: Queuing is not allowed in order to provide",!?6,"positive control over the registers.",!
  1.  Q