- PRSATAPE ; HISC/FPT-Load 8B's onto Tape ;8/17/95 08:43
- ;;4.0;PAID;;Sep 21, 1995
- ;
- ; HEADER = header for tape
- ; IEN = employee's internal entry number (file 450)
- ; LENGTH = length of record
- ; LOOP = 'for' loop variable
- ; MSGCNT = mail message count
- ; NAME = employee's name
- ; PPIEN = pay period internal entry number (file 458)
- ; RECCNT = number of 8b records
- ; RECORD = 8b record
- ; STUB = characters 1-32 of the 8b record
- ; SN = station number
- ;
- Q
- TAPE ; make a tape of 8b records
- S PPIEN=$P($G(^PRST(458,0)),U,3) I PPIEN<1 D KILL Q
- K DIC S DIC="^PRST(458,",DIC(0)="AEMQZ",DIC("B")=$P(^PRST(458,PPIEN,0),U,1) D ^DIC K DIC I +Y<1 D KILL Q
- S PPIEN=+Y
- K %ZIS S %ZIS("A")="Select TAPE Device: ",%ZIS("B")="",%ZIS="M" D ^%ZIS K %ZIS I POP D KILL,HOME^%ZIS Q
- U IO D LOAD D ^%ZISC,KILL Q
- LOAD ; load records onto tape
- S SN=$P($G(^XMB(1,1,"XUS")),"^",17),SN=$S(+SN>0:$P($G(^DIC(4,SN,99)),"^",1),1:"")
- S XMSUB=^DD("SITE")_" ("_SN_") PAYROLL DATA (PAY PERIOD "_$P($P(^PRST(458,PPIEN,0),U),"-",2)_")"
- S XMSUB=XMSUB_$J("",80-$L(XMSUB)),XMSUB=$E(XMSUB,1,80) U IO W XMSUB
- S (IEN,RECCNT)=0
- F S IEN=$O(^PRST(458,PPIEN,"E",IEN)) Q:IEN<1 D PROCESS I RECCNT#100=0 U IO(0) W "."
- U IO W "*** END ***"_$J("",69)
- Q
- PROCESS ; write records onto tape
- I '$D(^PRST(458,PPIEN,"E",IEN,5)) S NAME=$P($G(^PRSPC(IEN,0)),U,1) U IO(0) W !,"Missing 8B Record for ",$S(NAME'="":NAME,1:IEN) K NAME Q
- S RECORD=^PRST(458,PPIEN,"E",IEN,5),STUB=$E(RECORD,1,32)
- AGAIN I $L(RECORD)<81 S RECCNT=RECCNT+1 U IO W RECORD_$J("",80-$L(RECORD)) K LENGTH,RECORD,STUB Q
- F LENGTH=80:-1:33 Q:$E(RECORD,LENGTH-1,LENGTH)?2U
- U IO W $E(RECORD,1,LENGTH-2)_$J("",80-(LENGTH-2)) S RECCNT=RECCNT+1,RECORD=STUB_$E(RECORD,LENGTH-1,$L(RECORD)) G AGAIN
- Q
- ;
- MAIL ; move 8b tape data into mail messages
- K %ZIS S %ZIS("A")="Select TAPE Device: ",%ZIS("B")="",%ZIS="M" D ^%ZIS K %ZIS I POP D KILL,HOME^%ZIS Q
- S (MSGCNT,RECCNT)=0 U IO R HEADER:60 D M1 D ^%ZISC
- W !!,RECCNT," Records / ",MSGCNT," Messages",!
- KILL K %ZIS,HEADER,IEN,LOOP,MSGCNT,POP,PPIEN,RECCNT,SN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
- Q
- M1 ; move 8b records to mail messages
- K ^TMP($J) U IO F LOOP=1:1:175 R X:60 G:'$T!(X["*** END") M2 S ^TMP($J,LOOP,0)=X,RECCNT=RECCNT+1
- D M3 G M1
- M2 I $D(^TMP($J)) D M3 K ^TMP($J)
- Q
- M3 U IO(0) S XMY("XXX@Q-TAB.DOMAIN.EXT")="" U IO(0) W "."
- S XMSUB=HEADER
- S XMTEXT="^TMP($J,",XMDUZ=.5 D ^XMD S MSGCNT=MSGCNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATAPE 2466 printed Feb 18, 2025@23:50:54 Page 2
- PRSATAPE ; HISC/FPT-Load 8B's onto Tape ;8/17/95 08:43
- +1 ;;4.0;PAID;;Sep 21, 1995
- +2 ;
- +3 ; HEADER = header for tape
- +4 ; IEN = employee's internal entry number (file 450)
- +5 ; LENGTH = length of record
- +6 ; LOOP = 'for' loop variable
- +7 ; MSGCNT = mail message count
- +8 ; NAME = employee's name
- +9 ; PPIEN = pay period internal entry number (file 458)
- +10 ; RECCNT = number of 8b records
- +11 ; RECORD = 8b record
- +12 ; STUB = characters 1-32 of the 8b record
- +13 ; SN = station number
- +14 ;
- +15 QUIT
- TAPE ; make a tape of 8b records
- +1 SET PPIEN=$PIECE($GET(^PRST(458,0)),U,3)
- IF PPIEN<1
- DO KILL
- QUIT
- +2 KILL DIC
- SET DIC="^PRST(458,"
- SET DIC(0)="AEMQZ"
- SET DIC("B")=$PIECE(^PRST(458,PPIEN,0),U,1)
- DO ^DIC
- KILL DIC
- IF +Y<1
- DO KILL
- QUIT
- +3 SET PPIEN=+Y
- +4 KILL %ZIS
- SET %ZIS("A")="Select TAPE Device: "
- SET %ZIS("B")=""
- SET %ZIS="M"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- DO KILL
- DO HOME^%ZIS
- QUIT
- +5 USE IO
- DO LOAD
- DO ^%ZISC
- DO KILL
- QUIT
- LOAD ; load records onto tape
- +1 SET SN=$PIECE($GET(^XMB(1,1,"XUS")),"^",17)
- SET SN=$SELECT(+SN>0:$PIECE($GET(^DIC(4,SN,99)),"^",1),1:"")
- +2 SET XMSUB=^DD("SITE")_" ("_SN_") PAYROLL DATA (PAY PERIOD "_$PIECE($PIECE(^PRST(458,PPIEN,0),U),"-",2)_")"
- +3 SET XMSUB=XMSUB_$JUSTIFY("",80-$LENGTH(XMSUB))
- SET XMSUB=$EXTRACT(XMSUB,1,80)
- USE IO
- WRITE XMSUB
- +4 SET (IEN,RECCNT)=0
- +5 FOR
- SET IEN=$ORDER(^PRST(458,PPIEN,"E",IEN))
- if IEN<1
- QUIT
- DO PROCESS
- IF RECCNT#100=0
- USE IO(0)
- WRITE "."
- +6 USE IO
- WRITE "*** END ***"_$JUSTIFY("",69)
- +7 QUIT
- PROCESS ; write records onto tape
- +1 IF '$DATA(^PRST(458,PPIEN,"E",IEN,5))
- SET NAME=$PIECE($GET(^PRSPC(IEN,0)),U,1)
- USE IO(0)
- WRITE !,"Missing 8B Record for ",$SELECT(NAME'="":NAME,1:IEN)
- KILL NAME
- QUIT
- +2 SET RECORD=^PRST(458,PPIEN,"E",IEN,5)
- SET STUB=$EXTRACT(RECORD,1,32)
- AGAIN IF $LENGTH(RECORD)<81
- SET RECCNT=RECCNT+1
- USE IO
- WRITE RECORD_$JUSTIFY("",80-$LENGTH(RECORD))
- KILL LENGTH,RECORD,STUB
- QUIT
- +1 FOR LENGTH=80:-1:33
- if $EXTRACT(RECORD,LENGTH-1,LENGTH)?2U
- QUIT
- +2 USE IO
- WRITE $EXTRACT(RECORD,1,LENGTH-2)_$JUSTIFY("",80-(LENGTH-2))
- SET RECCNT=RECCNT+1
- SET RECORD=STUB_$EXTRACT(RECORD,LENGTH-1,$LENGTH(RECORD))
- GOTO AGAIN
- +3 QUIT
- +4 ;
- MAIL ; move 8b tape data into mail messages
- +1 KILL %ZIS
- SET %ZIS("A")="Select TAPE Device: "
- SET %ZIS("B")=""
- SET %ZIS="M"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- DO KILL
- DO HOME^%ZIS
- QUIT
- +2 SET (MSGCNT,RECCNT)=0
- USE IO
- READ HEADER:60
- DO M1
- DO ^%ZISC
- +3 WRITE !!,RECCNT," Records / ",MSGCNT," Messages",!
- KILL KILL %ZIS,HEADER,IEN,LOOP,MSGCNT,POP,PPIEN,RECCNT,SN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
- +1 QUIT
- M1 ; move 8b records to mail messages
- +1 KILL ^TMP($JOB)
- USE IO
- FOR LOOP=1:1:175
- READ X:60
- if '$TEST!(X["*** END")
- GOTO M2
- SET ^TMP($JOB,LOOP,0)=X
- SET RECCNT=RECCNT+1
- +2 DO M3
- GOTO M1
- M2 IF $DATA(^TMP($JOB))
- DO M3
- KILL ^TMP($JOB)
- +1 QUIT
- M3 USE IO(0)
- SET XMY("XXX@Q-TAB.DOMAIN.EXT")=""
- USE IO(0)
- WRITE "."
- +1 SET XMSUB=HEADER
- +2 SET XMTEXT="^TMP($J,"
- SET XMDUZ=.5
- DO ^XMD
- SET MSGCNT=MSGCNT+1
- +3 QUIT