AFSHBPRT ; IHS/OIRM/DSD/JDM -DHR BATCH PRINT PROGRAM ; [ 10/27/2004 4:20 PM ]
;;3.0T1;AO FINANCIAL DATA MGMT SYSTEM;**1,13**;FEB 02, 1999
;;MODIFIED FOR CACHE' COMPLIANCE ; ACR*2.1*9
D CRTSETUP^AFSHCRTS
A0 D ^XBCLS
F I=1:1:70 W "*"
W !,?10,"Document History Record (DHR) Batch Print Program",!
F I=1:1:70 W "*"
W !!
D5 S DY=22,DX=1 X XY X AFSLE W ?10,"Enter Batch COLOR to USE: (B/R) ('^' to EXIT) "
S DX=60,%L=1,%F="I",%T="A" X XY X AFSAD D ^AFSHDAT1
I AFSX1="^" G EXIT
I "BR"'[AFSX1!(AFSX1="") S DX=55 X XY X AFSLE W *7," INVALID ENTRY" H 2 G D5
S AFSLKEN="AFSEND"_$E(AFSHDTYP,1,1)_AFSX1_"("_$J_")",AFSLKENT=AFSLKEN_":1"
S AFSLKPGT="AFSEND"_$E(AFSHDTYP,1,1)_AFSX1_":1"
S AFSLKEXT="AFSEXDHR("_""""_$E(AFSHDTYP,1,1)_AFSX1_"""):1"
I AFSHDTYP="PCC" S AFSHBCLR=$S(AFSX1="B":1,AFSX1="R":2)
I AFSHDTYP="BCS" S AFSHBCLR=$S(AFSX1="B":3,AFSX1="R":4)
I AFSHDTYP="ARM" S AFSHBCLR=$S(AFSX1="B":5,AFSX1="R":6) ; TEMP ARMS TEST
D6 I '$D(AFSHBCNT(AFSHBCLR)) G E0
I $P(AFSHBCNT(AFSHBCLR,"STATUS"),"^",1)'="T" G E0
S DY=23,DX=1 X XY X AFSLE W ?10,*7,"Batch COLOR NOT AVAILABLE for Data Entry -- Select AGAIN" H 2 S DX=1 X XY X AFSLE G D5
E0 I '$D(AFSHNTRL(AFSHBCLR)) G E0C
;
E0C K AFSHBCNT,AFSHDSPL,AFSI,AFSR,AFSRR,AFSRRR,AFSBCNT
L @AFSLKEXT I '$T S DY=23,DX=1 X XY X AFSLE W ?10,*7,"Export Job Running -- Batch Printing NOT Available" H 2 S DX=1 X XY X AFSLE G D5
L @AFSLKPGT I '$T U IO(0) W !!,*7,?10,"***** OTHER USERS ARE ACTIVE -- PLEASE CONTINUE *****" H 2
BSELECT S AFSCNT=0 K AFSBINFO
S %DT="AEX",%DT("A")="ENTER BATCH DATE TO PRINT: " D ^%DT ;ACR*2.1*13.02 IM13574
I $D(DQOUT) G BSELA
I $D(DTOUT)!($D(DUOUT)) G EXIT
I Y="?" G BSELA
S AFSHBID="" W !! G BSELA1
BSELA S AFSHBDAT=0,AFSHBID="" W !!
BSELA1 S AFSHBDAT=$O(^AFSHRCDS(AFSHBCLR,"D","B",AFSHBDAT)) G BSELEND:AFSHBDAT=""
BSELA2 S AFSHBID=$O(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I","B",AFSHBID)) G BSELA1:AFSHBID=""
S AFSHBDFN=0,AFSHBDFN=$O(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I","B",AFSHBID,AFSHBDFN))
G BSELA2:AFSHBDFN<1
S AFSCNT=AFSCNT+1,AFSBINFO(AFSCNT)=AFSHBDAT_"^"_AFSHBDFN
;Beginning Y2K fix
;W $J(("["_$J(AFSCNT,2)_"] "_$E(AFSHBDAT,4,5)_"/"_$E(AFSHBDAT,6,7)_"/"_$E(AFSHBDAT,2,3)_"-"_AFSHBID_"("_$P(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I",AFSHBDFN,"S",0),"^",4)_")"),20)
W $J(("["_$J(AFSCNT,2)_"] "_$E(AFSHBDAT,4,5)_"/"_$E(AFSHBDAT,6,7)_"/"_$E(AFSHBDAT,1,3)+1700_"-"_AFSHBID_"("_$P(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I",AFSHBDFN,"S",0),"^",4)_")"),20) ;Y2000;HJT;AFSH*3.0T1*1
;End Y2K fix block
G BSELA2
BSELEND W !! S DIR(0)="N^1:"_AFSCNT,DIR("A")="ENTER BATCH SEQUENCE # ([ ]) TO PRINT" D ^DIR
S AFSHBDAT=$P(AFSBINFO(Y),"^",1),AFSHBDFN=$P(AFSBINFO(Y),"^",2)
G B0
EXIT G DENTRY^AFSHVKIL
;L Q ; ACR*2.1*13.02 IM13574
Q ; ACR*2.1*13.02 IM13574
;
;SBRS K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT R Y:DTIME I '$T W *7 R Y:5 G SBRS:Y="." I '$T S (DTOUT,Y)="" Q ; ACR*2.1*13.02 IM13574
;S:Y="/.," (DFOUT,Y)="" S:Y="" DLOUT="" S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") S (DQOUT,Y)="" ; ACR*2.1*13.02 IM13574
;Q
SBRS K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT ; ACR*2.1*13.02 IM13574
N DIR ; ACR*2.1*13.02 IM13574
S DIR(0)="F" ; ACR*2.1*13.02 IM13574
D DIR^ACRFDIC ; ACR*2.1*13.02 IM13574
I $D(DTOUT)!($D(DIROUT))!($D(DIRUT))!($D(DUOUT)) S Y="" Q ; ACR*2.1*13.02 IM13574
G SBRS:Y="." ; ACR*2.1*13.02 IM13574
S:Y="/.," (DFOUT,Y)="" S:Y="" DLOUT="" S:Y?1"?".E (DQOUT,Y)="" ; ACR*2.1*13.02 IM13574
Q
B0 S AFSR=AFSHBCLR,(AFSRR,AFSRRR,AFSRRRR)=0
B1 S AFSRR=$O(^AFSHRCDS(AFSR,"D","B",AFSRR)) G ZEND:+AFSRR=0
B2 S AFSRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR)) G B1:AFSRRR=""
S AFSRRRP=0,AFSRRRP=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR,AFSRRRP))
S AFSRRA=$P(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,0),"^",1),AFSHBCNT=$P(^(0),"^",5),AFSHBTOT=$P(^(0),"^",6),AFSHBAP=$P(^(0),"^",2)
S AFSHBDAT=AFSRR D PCCHDR^AFSHBPR1
S AFSRRRR=0
B3 S AFSRRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR)) G BTRL:+AFSRRRR=0
S AFSHYY=^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,0)
I AFSRRRR#100=0 U IO(0) W $J(AFSRRRR,8)
D ^AFSHEX2
S AFSHTRCT=AFSHTRCT+1,AFSHPLCT=AFSHPLCT+1
G B3
BTRL D PCCTRL^AFSHBPR1
G B2
ZEND D PCCJTRL^AFSQEX1
I AFSHPLCT>55 D PTRHDR^AFSHEX2
U AFSHPTRD W !!,?10,"NUMBER OF OUTPUT DHR RECORDS = ",?45,$J(AFSHTRCT,8),!!,?10,"NUMBER OF JCL RECORDS = ",?45,$J(8,8),!!
S X="",$P(X,"-",44)="" W ?10,X,!,?15,"TOTAL RECORDS TO TRANSMIT = ",?45,$J(AFSHTRCT+8,8),!!
Q
AFSHBPRT ; IHS/OIRM/DSD/JDM -DHR BATCH PRINT PROGRAM ; [ 10/27/2004 4:20 PM ]
+1 ;;3.0T1;AO FINANCIAL DATA MGMT SYSTEM;**1,13**;FEB 02, 1999
+2 ;;MODIFIED FOR CACHE' COMPLIANCE ; ACR*2.1*9
+3 DO CRTSETUP^AFSHCRTS
A0 DO ^XBCLS
+1 FOR I=1:1:70
WRITE "*"
+2 WRITE !,?10,"Document History Record (DHR) Batch Print Program",!
+3 FOR I=1:1:70
WRITE "*"
+4 WRITE !!
D5 SET DY=22
SET DX=1
XECUTE XY
XECUTE AFSLE
WRITE ?10,"Enter Batch COLOR to USE: (B/R) ('^' to EXIT) "
+1 SET DX=60
SET %L=1
SET %F="I"
SET %T="A"
XECUTE XY
XECUTE AFSAD
DO ^AFSHDAT1
+2 IF AFSX1="^"
GOTO EXIT
+3 IF "BR"'[AFSX1!(AFSX1="")
SET DX=55
XECUTE XY
XECUTE AFSLE
WRITE *7," INVALID ENTRY"
HANG 2
GOTO D5
+4 SET AFSLKEN="AFSEND"_$EXTRACT(AFSHDTYP,1,1)_AFSX1_"("_$JOB_")"
SET AFSLKENT=AFSLKEN_":1"
+5 SET AFSLKPGT="AFSEND"_$EXTRACT(AFSHDTYP,1,1)_AFSX1_":1"
+6 SET AFSLKEXT="AFSEXDHR("_""""_$EXTRACT(AFSHDTYP,1,1)_AFSX1_"""):1"
+7 IF AFSHDTYP="PCC"
SET AFSHBCLR=$SELECT(AFSX1="B":1,AFSX1="R":2)
+8 IF AFSHDTYP="BCS"
SET AFSHBCLR=$SELECT(AFSX1="B":3,AFSX1="R":4)
+9 ; TEMP ARMS TEST
IF AFSHDTYP="ARM"
SET AFSHBCLR=$SELECT(AFSX1="B":5,AFSX1="R":6)
D6 IF '$DATA(AFSHBCNT(AFSHBCLR))
GOTO E0
+1 IF $PIECE(AFSHBCNT(AFSHBCLR,"STATUS"),"^",1)'="T"
GOTO E0
+2 SET DY=23
SET DX=1
XECUTE XY
XECUTE AFSLE
WRITE ?10,*7,"Batch COLOR NOT AVAILABLE for Data Entry -- Select AGAIN"
HANG 2
SET DX=1
XECUTE XY
XECUTE AFSLE
GOTO D5
E0 IF '$DATA(AFSHNTRL(AFSHBCLR))
GOTO E0C
+1 ;
E0C KILL AFSHBCNT,AFSHDSPL,AFSI,AFSR,AFSRR,AFSRRR,AFSBCNT
+1 LOCK @AFSLKEXT
IF '$TEST
SET DY=23
SET DX=1
XECUTE XY
XECUTE AFSLE
WRITE ?10,*7,"Export Job Running -- Batch Printing NOT Available"
HANG 2
SET DX=1
XECUTE XY
XECUTE AFSLE
GOTO D5
+2 LOCK @AFSLKPGT
IF '$TEST
USE IO(0)
WRITE !!,*7,?10,"***** OTHER USERS ARE ACTIVE -- PLEASE CONTINUE *****"
HANG 2
BSELECT SET AFSCNT=0
KILL AFSBINFO
+1 ;ACR*2.1*13.02 IM13574
SET %DT="AEX"
SET %DT("A")="ENTER BATCH DATE TO PRINT: "
DO ^%DT
+2 IF $DATA(DQOUT)
GOTO BSELA
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+4 IF Y="?"
GOTO BSELA
+5 SET AFSHBID=""
WRITE !!
GOTO BSELA1
BSELA SET AFSHBDAT=0
SET AFSHBID=""
WRITE !!
BSELA1 SET AFSHBDAT=$ORDER(^AFSHRCDS(AFSHBCLR,"D","B",AFSHBDAT))
IF AFSHBDAT=""
GOTO BSELEND
BSELA2 SET AFSHBID=$ORDER(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I","B",AFSHBID))
IF AFSHBID=""
GOTO BSELA1
+1 SET AFSHBDFN=0
SET AFSHBDFN=$ORDER(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I","B",AFSHBID,AFSHBDFN))
+2 IF AFSHBDFN<1
GOTO BSELA2
+3 SET AFSCNT=AFSCNT+1
SET AFSBINFO(AFSCNT)=AFSHBDAT_"^"_AFSHBDFN
+4 ;Beginning Y2K fix
+5 ;W $J(("["_$J(AFSCNT,2)_"] "_$E(AFSHBDAT,4,5)_"/"_$E(AFSHBDAT,6,7)_"/"_$E(AFSHBDAT,2,3)_"-"_AFSHBID_"("_$P(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I",AFSHBDFN,"S",0),"^",4)_")"),20)
+6 ;Y2000;HJT;AFSH*3.0T1*1
WRITE $JUSTIFY(("["_$JUSTIFY(AFSCNT,2)_"] "_$EXTRACT(AFSHBDAT,4,5)_"/"_$EXTRACT(AFSHBDAT,6,7)_"/"_$EXTRACT(AFSHBDAT,1,3)+1700_"-"_AFSHBID_"("_$PIECE(^AFSHRCDS(AFSHBCLR,"D",AFSHBDAT,"I",AFSHBDFN,"S",0),"^",4)_")"),20)
+7 ;End Y2K fix block
+8 GOTO BSELA2
BSELEND WRITE !!
SET DIR(0)="N^1:"_AFSCNT
SET DIR("A")="ENTER BATCH SEQUENCE # ([ ]) TO PRINT"
DO ^DIR
+1 SET AFSHBDAT=$PIECE(AFSBINFO(Y),"^",1)
SET AFSHBDFN=$PIECE(AFSBINFO(Y),"^",2)
+2 GOTO B0
EXIT GOTO DENTRY^AFSHVKIL
+1 ;L Q ; ACR*2.1*13.02 IM13574
+2 ; ACR*2.1*13.02 IM13574
QUIT
+3 ;
+4 ;SBRS K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT R Y:DTIME I '$T W *7 R Y:5 G SBRS:Y="." I '$T S (DTOUT,Y)="" Q ; ACR*2.1*13.02 IM13574
+5 ;S:Y="/.," (DFOUT,Y)="" S:Y="" DLOUT="" S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") S (DQOUT,Y)="" ; ACR*2.1*13.02 IM13574
+6 ;Q
SBRS ; ACR*2.1*13.02 IM13574
KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
+1 ; ACR*2.1*13.02 IM13574
NEW DIR
+2 ; ACR*2.1*13.02 IM13574
SET DIR(0)="F"
+3 ; ACR*2.1*13.02 IM13574
DO DIR^ACRFDIC
+4 ; ACR*2.1*13.02 IM13574
IF $DATA(DTOUT)!($DATA(DIROUT))!($DATA(DIRUT))!($DATA(DUOUT))
SET Y=""
QUIT
+5 ; ACR*2.1*13.02 IM13574
IF Y="."
GOTO SBRS
+6 ; ACR*2.1*13.02 IM13574
IF Y="/.,"
SET (DFOUT,Y)=""
IF Y=""
SET DLOUT=""
IF Y?1"?".E
SET (DQOUT,Y)=""
+7 QUIT
B0 SET AFSR=AFSHBCLR
SET (AFSRR,AFSRRR,AFSRRRR)=0
B1 SET AFSRR=$ORDER(^AFSHRCDS(AFSR,"D","B",AFSRR))
IF +AFSRR=0
GOTO ZEND
B2 SET AFSRRR=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR))
IF AFSRRR=""
GOTO B1
+1 SET AFSRRRP=0
SET AFSRRRP=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR,AFSRRRP))
+2 SET AFSRRA=$PIECE(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,0),"^",1)
SET AFSHBCNT=$PIECE(^(0),"^",5)
SET AFSHBTOT=$PIECE(^(0),"^",6)
SET AFSHBAP=$PIECE(^(0),"^",2)
+3 SET AFSHBDAT=AFSRR
DO PCCHDR^AFSHBPR1
+4 SET AFSRRRR=0
B3 SET AFSRRRR=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR))
IF +AFSRRRR=0
GOTO BTRL
+1 SET AFSHYY=^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,0)
+2 IF AFSRRRR#100=0
USE IO(0)
WRITE $JUSTIFY(AFSRRRR,8)
+3 DO ^AFSHEX2
+4 SET AFSHTRCT=AFSHTRCT+1
SET AFSHPLCT=AFSHPLCT+1
+5 GOTO B3
BTRL DO PCCTRL^AFSHBPR1
+1 GOTO B2
ZEND DO PCCJTRL^AFSQEX1
+1 IF AFSHPLCT>55
DO PTRHDR^AFSHEX2
+2 USE AFSHPTRD
WRITE !!,?10,"NUMBER OF OUTPUT DHR RECORDS = ",?45,$JUSTIFY(AFSHTRCT,8),!!,?10,"NUMBER OF JCL RECORDS = ",?45,$JUSTIFY(8,8),!!
+3 SET X=""
SET $PIECE(X,"-",44)=""
WRITE ?10,X,!,?15,"TOTAL RECORDS TO TRANSMIT = ",?45,$JUSTIFY(AFSHTRCT+8,8),!!
+4 QUIT
