AFSLRTT3 ;IHS/OIRM/OKCRDC/JDM - WRITE TO 9-TRACK TAPE; [ 10/27/2004 4:21 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;
;;ACR*2.1*9 MODIFICATIONS FOR CACHE' COMPLIANCE
FRD ;EP-open unix file, read, and send to 9 track tape
;I $D(IO("Q")) S ZTRTN="START^AFSLRTT3",ZTSAVE("AFS*")="",ZTSAVE("IO*")="" D ^%ZTLOAD Q
START S %FN=AFSEXFN,%IN=1 S (AFSLIC,AFSLXZ,AFSLIC1,AFSLTMPX,AFSLBKCT,AFSLGFLG)=0,(AFSLXA,AFSLXC,AFSLXX,AFSLTMXX)=""
I $D(^AFSLPRM(AFSLTDPM,2)) S X=$P(^(2),U,1)
E U IO(0) W !!!,"THERE IS NO 9-TRACK TAPE DEVICE IN THE 1166 PARAMETERS FILE. YOU CANNOT RUN THIS OPTION UNTIL THIS IS CORRECT" Q
S DIC="^%ZIS(1,"
S DIC(0)=""
D ^DIC
I +Y'>-1 U IO(0) W !!!,"THE 9-TRACK TAPE DEVICE IN THE 1166 PARMETERS FILE, IS NOT IN THE DEVICE FILE. CORRECT THE 1166 PARAMETERS FILE." Q
S (AFSLTP1,IOP)=X
S AFSLIO0=IO(0)
D TAPE^AFSLTT4
S IOP=AFSLTP1
S %ZIS("IOPAR")="(""EFUT"":1048:1048:"""")"_":1" D ^%ZIS S AFSLTAP=IO
I POP D ^XBCLS W !!,"TAPE DRIVE ERROR!" H 3 S AFSLEFLG=1 Q
U AFSLTAP W *1
D OPENHFS^AFSTCK1
;I $D(AFSERMSG) D ERROR^AFSTCK1 S IO=AFSLTAP D ^%ZISC G FINI^AFSLKILL Q ; ACR*2.1*13.02 IM13574
;S IO=%DEV ; ACR*2.1*13.02 IM13574
I $D(AFSERMSG) D G FINI^AFSLKILL ; ACR*2.1*13.02 IM13574
.D ERROR^AFSTCK1 ; ACR*2.1*13.02 IM13574
.D CLOSE^%ZISH() ; ACR*2.1*13.02 IM13574
F AFSLI=1:1 U IO R X:DTIME D ^AFSLCKZC U AFSLIO0 Q:AFSLNZC=-1!($A(X)=-1)!(AFSLGFLG=1) S AFSLXX=$E(X,4,84),AFSLXZ=$E(X,1,3),AFSLBKCT=AFSLBKCT+1 D:$A($E(AFSLXZ,1))=66 ITEM I $E(AFSLXZ,1)'["B" D HDTRL
F AFSLI=1:1 U IO R X:DTIME D ^AFSLCKZC U AFSLIO0 Q:AFSLNZC=-1!($A(X)=-1)!(AFSLGFLG=1)!(X["JV")
U AFSLDEV W @IOF
U AFSLTAP W *3
;U AFSLIO0 S IO=AFSLTAP D ^%ZISC ; ACR*2.1*13.02 IM13574
U AFSLIO0 D ^%ZISC ; ACR*2.1*13.02 IM13574
D EOF^AFSLTT4
Q
ITEM ;process payment item data
I AFSLIC1=1 S X=AFSLXA_$J("",895),AFSLXB=AFSLXX D TAPE S AFSLXX=AFSLXB S AFSLIC1=0
I $E(AFSLXZ,1,3)["B01",AFSLIC>0 S AFSLXB=AFSLXX,X=$J("",12-AFSLIC*55)_" " D TAPE S AFSLXX=AFSLXB,AFSLIC=0
I $E(AFSLXZ,1,3)["B01" S AFSLXC=AFSLXC_AFSLXX Q ;ACR*2.1*13.02 IM13574
I $E(AFSLXZ,1,3)["B02" S X=AFSLXC_"DOC. NO AMT PAID *********** PAID FOR *********"_$J("",55),AFSLXB=AFSLXX,AFSLXC="" D TAPE S AFSLXX=AFSLXB
S AFSLIC=AFSLIC+1
S X=AFSLXX D TAPE
Q
HDTRL ;
I $E(AFSLXZ,1)["A" S AFSLIC1=1,AFSLXA=AFSLXA_AFSLXX Q
I $E(AFSLXZ,1)["C" S AFSLXB=AFSLXX,X=$S(AFSLIC>0:$J("",12-AFSLIC*55)_" ",1:"") D TAPE S AFSLXX=AFSLXB
I $E(AFSLXZ,1)'["A" S X=AFSLXX_$J("",1005) D TAPE
Q
TAPE ;write to tape
S AFSLTMPX=X,AFSLTMXX=AFSLTMXX_X
I $L(AFSLTMXX)>1047 D RPT S X=AFSLTMPX,AFSLTMXX=""
U AFSLTAP W X
S (AFSLXX,X)=""
Q
RPT ;module to generate report containing all records included on treasury tape
S X=AFSLTMXX
Q:"A&C"[$E(X,43)
I "D"[$E(X,43) D TOTS Q
U AFSLDEV
I '$D(AFSLLCT) D HDR
I AFSLLCT>(AFSLDSL-17) D HDR
SHDR ;Vendor name,address,record total,ein #
W $E(X,44,78),?40,$E(X,79,113) ;VENDOR NAME AND 1ST LINE OF ADDRESS
S AFSLST=$S($E(X,179,208)[$E(AFSLSP,1,30):0,1:" "_$E(X,179,208))
I AFSLST=0 S AFSLST=$S($E(X,149,178)[$E(AFSLSP,1,30):0,1:" "_$E(X,149,178))
I AFSLST=0 S AFSLST=$E(X,114,148)
W ?80,AFSLST ;VENDOR CITY,STATE,AND ZIP
S AFSLWTOT=X,X=$E(AFSLWTOT,24,32)/100,X2="2$" D COMMA^%DTC
W ?110,X S X=AFSLWTOT,AFSLWTOT=0 ;RECORD TOTAL AMOUNT
W !!,"EIN #",?8,$E(X,12,23),?22,$E(X,278,332)
W !! S AFSLLCT=AFSLLCT+4
WITEM ;item information for each record
I $E(X,388,442)'[AFSLSP W !,?22,$E(X,388,442) S AFSLLCT=AFSLLCT+1
I $E(X,443,497)'[AFSLSP W !,?22,$E(X,443,497) S AFSLLCT=AFSLLCT+1
I $E(X,498,552)'[AFSLSP W !,?22,$E(X,498,552) S AFSLLCT=AFSLLCT+1
I $E(X,553,607)'[AFSLSP W !,?22,$E(X,553,607) S AFSLLCT=AFSLLCT+1
I $E(X,608,662)'[AFSLSP W !,?22,$E(X,608,662) S AFSLLCT=AFSLLCT+1
I $E(X,663,717)'[AFSLSP W !,?22,$E(X,663,717) S AFSLLCT=AFSLLCT+1
I $E(X,718,772)'[AFSLSP W !,?22,$E(X,718,772) S AFSLLCT=AFSLLCT+1
I $E(X,773,827)'[AFSLSP W !,?22,$E(X,773,827) S AFSLLCT=AFSLLCT+1
I $E(X,828,882)'[AFSLSP W !,?22,$E(X,828,882) S AFSLLCT=AFSLLCT+1
I $E(X,883,937)'[AFSLSP W !,?22,$E(X,883,937) S AFSLLCT=AFSLLCT+1
I $E(X,938,992)'[AFSLSP W !,?22,$E(X,938,992) S AFSLLCT=AFSLLCT+1
I $E(X,993,1047)'[AFSLSP W !,?22,$E(X,993,1047) S AFSLLCT=AFSLLCT+1
W !! S AFSLLCT=AFSLLCT+2
Q
HDR ;header information
W @IOF
S AFSLLCT=0 S:'$D(AFSLSP) AFSLSP=" "
I '$D(AFSLRDT) S Y=DT X ^DD("DD") S AFSLRDT=Y
W AFSLRDT,?18,"********************",?49,"INDIAN HEALTH SERVICE"
W ?89,"********************",?109,"PAGE " W $S($D(AFSLPG):AFSLPG,1:1)
S AFSLPG=$S($D(AFSLPG):AFSLPG+1,1:2)
W !!,?20,"TREASURY TAPE (1166) GENERATION PROGRAM",?92,"SCHEDULE NUMBER"
W ?112,$E(X,1,10),!! S AFSLLCT=AFSLLCT+4
Q
TOTS ;
U AFSLDEV
S AFSLCDT=X,X=$E(X,31,42)/100,X1="2$" D COMMA^%DTC S AFSLDCT=X,X=AFSLCDT
W "RECORD TOTAL: ",+$E(X,24,30),?50,"TOTAL AMOUNT: ",AFSLDCT
Q
TAPSTOP ;
U AFSLIO0 W !!!,"VENDOR: ",$E(AFSLXX,46,84),?50,"EIN: ",$E(AFSLXX,15,26),?65,"BAD FORMAT"
Q
AFSLRTT3 ;IHS/OIRM/OKCRDC/JDM - WRITE TO 9-TRACK TAPE; [ 10/27/2004 4:21 PM ]
+1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;
+2 ;;ACR*2.1*9 MODIFICATIONS FOR CACHE' COMPLIANCE
FRD ;EP-open unix file, read, and send to 9 track tape
+1 ;I $D(IO("Q")) S ZTRTN="START^AFSLRTT3",ZTSAVE("AFS*")="",ZTSAVE("IO*")="" D ^%ZTLOAD Q
START SET %FN=AFSEXFN
SET %IN=1
SET (AFSLIC,AFSLXZ,AFSLIC1,AFSLTMPX,AFSLBKCT,AFSLGFLG)=0
SET (AFSLXA,AFSLXC,AFSLXX,AFSLTMXX)=""
+1 IF $DATA(^AFSLPRM(AFSLTDPM,2))
SET X=$PIECE(^(2),U,1)
+2 IF '$TEST
USE IO(0)
WRITE !!!,"THERE IS NO 9-TRACK TAPE DEVICE IN THE 1166 PARAMETERS FILE. YOU CANNOT RUN THIS OPTION UNTIL THIS IS CORRECT"
QUIT
+3 SET DIC="^%ZIS(1,"
+4 SET DIC(0)=""
+5 DO ^DIC
+6 IF +Y'>-1
USE IO(0)
WRITE !!!,"THE 9-TRACK TAPE DEVICE IN THE 1166 PARMETERS FILE, IS NOT IN THE DEVICE FILE. CORRECT THE 1166 PARAMETERS FILE."
QUIT
+7 SET (AFSLTP1,IOP)=X
+8 SET AFSLIO0=IO(0)
+9 DO TAPE^AFSLTT4
+10 SET IOP=AFSLTP1
+11 SET %ZIS("IOPAR")="(""EFUT"":1048:1048:"""")"_":1"
DO ^%ZIS
SET AFSLTAP=IO
+12 IF POP
DO ^XBCLS
WRITE !!,"TAPE DRIVE ERROR!"
HANG 3
SET AFSLEFLG=1
QUIT
+13 USE AFSLTAP
WRITE *1
+14 DO OPENHFS^AFSTCK1
+15 ;I $D(AFSERMSG) D ERROR^AFSTCK1 S IO=AFSLTAP D ^%ZISC G FINI^AFSLKILL Q ; ACR*2.1*13.02 IM13574
+16 ;S IO=%DEV ; ACR*2.1*13.02 IM13574
+17 ; ACR*2.1*13.02 IM13574
IF $DATA(AFSERMSG)
Begin DoDot:1
+18 ; ACR*2.1*13.02 IM13574
DO ERROR^AFSTCK1
+19 ; ACR*2.1*13.02 IM13574
DO CLOSE^%ZISH()
End DoDot:1
GOTO FINI^AFSLKILL
+20 FOR AFSLI=1:1
USE IO
READ X:DTIME
DO ^AFSLCKZC
USE AFSLIO0
IF AFSLNZC=-1!($ASCII(X)=-1)!(AFSLGFLG=1)
QUIT
SET AFSLXX=$EXTRACT(X,4,84)
SET AFSLXZ=$EXTRACT(X,1,3)
SET AFSLBKCT=AFSLBKCT+1
IF $ASCII($EXTRACT(AFSLXZ,1))=66
DO ITEM
IF $EXTRACT(AFSLXZ,1)'["B"
DO HDTRL
+21 FOR AFSLI=1:1
USE IO
READ X:DTIME
DO ^AFSLCKZC
USE AFSLIO0
IF AFSLNZC=-1!($ASCII(X)=-1)!(AFSLGFLG=1)!(X["JV")
QUIT
+22 USE AFSLDEV
WRITE @IOF
+23 USE AFSLTAP
WRITE *3
+24 ;U AFSLIO0 S IO=AFSLTAP D ^%ZISC ; ACR*2.1*13.02 IM13574
+25 ; ACR*2.1*13.02 IM13574
USE AFSLIO0
DO ^%ZISC
+26 DO EOF^AFSLTT4
+27 QUIT
ITEM ;process payment item data
+1 IF AFSLIC1=1
SET X=AFSLXA_$JUSTIFY("",895)
SET AFSLXB=AFSLXX
DO TAPE
SET AFSLXX=AFSLXB
SET AFSLIC1=0
+2 IF $EXTRACT(AFSLXZ,1,3)["B01"
IF AFSLIC>0
SET AFSLXB=AFSLXX
SET X=$JUSTIFY("",12-AFSLIC*55)_" "
DO TAPE
SET AFSLXX=AFSLXB
SET AFSLIC=0
+3 ;ACR*2.1*13.02 IM13574
IF $EXTRACT(AFSLXZ,1,3)["B01"
SET AFSLXC=AFSLXC_AFSLXX
QUIT
+4 IF $EXTRACT(AFSLXZ,1,3)["B02"
SET X=AFSLXC_"DOC. NO AMT PAID *********** PAID FOR *********"_$JUSTIFY("",55)
SET AFSLXB=AFSLXX
SET AFSLXC=""
DO TAPE
SET AFSLXX=AFSLXB
+5 SET AFSLIC=AFSLIC+1
+6 SET X=AFSLXX
DO TAPE
+7 QUIT
HDTRL ;
+1 IF $EXTRACT(AFSLXZ,1)["A"
SET AFSLIC1=1
SET AFSLXA=AFSLXA_AFSLXX
QUIT
+2 IF $EXTRACT(AFSLXZ,1)["C"
SET AFSLXB=AFSLXX
SET X=$SELECT(AFSLIC>0:$JUSTIFY("",12-AFSLIC*55)_" ",1:"")
DO TAPE
SET AFSLXX=AFSLXB
+3 IF $EXTRACT(AFSLXZ,1)'["A"
SET X=AFSLXX_$JUSTIFY("",1005)
DO TAPE
+4 QUIT
TAPE ;write to tape
+1 SET AFSLTMPX=X
SET AFSLTMXX=AFSLTMXX_X
+2 IF $LENGTH(AFSLTMXX)>1047
DO RPT
SET X=AFSLTMPX
SET AFSLTMXX=""
+3 USE AFSLTAP
WRITE X
+4 SET (AFSLXX,X)=""
+5 QUIT
RPT ;module to generate report containing all records included on treasury tape
+1 SET X=AFSLTMXX
+2 IF "A&C"[$EXTRACT(X,43)
QUIT
+3 IF "D"[$EXTRACT(X,43)
DO TOTS
QUIT
+4 USE AFSLDEV
+5 IF '$DATA(AFSLLCT)
DO HDR
+6 IF AFSLLCT>(AFSLDSL-17)
DO HDR
SHDR ;Vendor name,address,record total,ein #
+1 ;VENDOR NAME AND 1ST LINE OF ADDRESS
WRITE $EXTRACT(X,44,78),?40,$EXTRACT(X,79,113)
+2 SET AFSLST=$SELECT($EXTRACT(X,179,208)[$EXTRACT(AFSLSP,1,30):0,1:" "_$EXTRACT(X,179,208))
+3 IF AFSLST=0
SET AFSLST=$SELECT($EXTRACT(X,149,178)[$EXTRACT(AFSLSP,1,30):0,1:" "_$EXTRACT(X,149,178))
+4 IF AFSLST=0
SET AFSLST=$EXTRACT(X,114,148)
+5 ;VENDOR CITY,STATE,AND ZIP
WRITE ?80,AFSLST
+6 SET AFSLWTOT=X
SET X=$EXTRACT(AFSLWTOT,24,32)/100
SET X2="2$"
DO COMMA^%DTC
+7 ;RECORD TOTAL AMOUNT
WRITE ?110,X
SET X=AFSLWTOT
SET AFSLWTOT=0
+8 WRITE !!,"EIN #",?8,$EXTRACT(X,12,23),?22,$EXTRACT(X,278,332)
+9 WRITE !!
SET AFSLLCT=AFSLLCT+4
WITEM ;item information for each record
+1 IF $EXTRACT(X,388,442)'[AFSLSP
WRITE !,?22,$EXTRACT(X,388,442)
SET AFSLLCT=AFSLLCT+1
+2 IF $EXTRACT(X,443,497)'[AFSLSP
WRITE !,?22,$EXTRACT(X,443,497)
SET AFSLLCT=AFSLLCT+1
+3 IF $EXTRACT(X,498,552)'[AFSLSP
WRITE !,?22,$EXTRACT(X,498,552)
SET AFSLLCT=AFSLLCT+1
+4 IF $EXTRACT(X,553,607)'[AFSLSP
WRITE !,?22,$EXTRACT(X,553,607)
SET AFSLLCT=AFSLLCT+1
+5 IF $EXTRACT(X,608,662)'[AFSLSP
WRITE !,?22,$EXTRACT(X,608,662)
SET AFSLLCT=AFSLLCT+1
+6 IF $EXTRACT(X,663,717)'[AFSLSP
WRITE !,?22,$EXTRACT(X,663,717)
SET AFSLLCT=AFSLLCT+1
+7 IF $EXTRACT(X,718,772)'[AFSLSP
WRITE !,?22,$EXTRACT(X,718,772)
SET AFSLLCT=AFSLLCT+1
+8 IF $EXTRACT(X,773,827)'[AFSLSP
WRITE !,?22,$EXTRACT(X,773,827)
SET AFSLLCT=AFSLLCT+1
+9 IF $EXTRACT(X,828,882)'[AFSLSP
WRITE !,?22,$EXTRACT(X,828,882)
SET AFSLLCT=AFSLLCT+1
+10 IF $EXTRACT(X,883,937)'[AFSLSP
WRITE !,?22,$EXTRACT(X,883,937)
SET AFSLLCT=AFSLLCT+1
+11 IF $EXTRACT(X,938,992)'[AFSLSP
WRITE !,?22,$EXTRACT(X,938,992)
SET AFSLLCT=AFSLLCT+1
+12 IF $EXTRACT(X,993,1047)'[AFSLSP
WRITE !,?22,$EXTRACT(X,993,1047)
SET AFSLLCT=AFSLLCT+1
+13 WRITE !!
SET AFSLLCT=AFSLLCT+2
+14 QUIT
HDR ;header information
+1 WRITE @IOF
+2 SET AFSLLCT=0
IF '$DATA(AFSLSP)
SET AFSLSP=" "
+3 IF '$DATA(AFSLRDT)
SET Y=DT
XECUTE ^DD("DD")
SET AFSLRDT=Y
+4 WRITE AFSLRDT,?18,"********************",?49,"INDIAN HEALTH SERVICE"
+5 WRITE ?89,"********************",?109,"PAGE "
WRITE $SELECT($DATA(AFSLPG):AFSLPG,1:1)
+6 SET AFSLPG=$SELECT($DATA(AFSLPG):AFSLPG+1,1:2)
+7 WRITE !!,?20,"TREASURY TAPE (1166) GENERATION PROGRAM",?92,"SCHEDULE NUMBER"
+8 WRITE ?112,$EXTRACT(X,1,10),!!
SET AFSLLCT=AFSLLCT+4
+9 QUIT
TOTS ;
+1 USE AFSLDEV
+2 SET AFSLCDT=X
SET X=$EXTRACT(X,31,42)/100
SET X1="2$"
DO COMMA^%DTC
SET AFSLDCT=X
SET X=AFSLCDT
+3 WRITE "RECORD TOTAL: ",+$EXTRACT(X,24,30),?50,"TOTAL AMOUNT: ",AFSLDCT
+4 QUIT
TAPSTOP ;
+1 USE AFSLIO0
WRITE !!!,"VENDOR: ",$EXTRACT(AFSLXX,46,84),?50,"EIN: ",$EXTRACT(AFSLXX,15,26),?65,"BAD FORMAT"
+2 QUIT
