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