- PSXARC1 ;BIR/HTW-Gather Data to Archive ;02 Aug 2001 9:57 AM
- ;;2.0;CMOP;**26,38**;11 Apr 97
- ; Reference to file #200 supported by DBIA 10060
- S (LN,PG,CT)=1,(X,LEN,BATCT,RXCT)=0,PAD=" "
- TAPEHDR U PSXT W "$$HDR|CMOP MASTER ARCHIVE^"_PSXTAPE
- D NOW^%DTC S Y=% X ^DD("DD") K %
- U IO(0) W @PSXIOF,?10,"CMOP MASTER DATABASE ARCHIVE",?45,Y
- MAIN ;
- U IO(0) W !!,"Recording data on tape # ",PSXTAPE,". Write this number on the tape label!!",!!
- F ZZZ=0:0 S ZZZ=$O(^TMP("PSX",$J,ZZZ)) Q:'ZZZ D ONE S ^PSX(552.1,I21,-9)=""
- U IO(0) W !!,"Total # of Transmissions Archived: ",$G(BATCT)
- U IO(0) W !,"Total # of Rx's Archived : ",$G(RXCT)
- U IO(0) W !,"Total Bytes Archived : ",$G(T1)+$G(T2)
- D NOW^%DTC S Y=% X ^DD("DD")
- U IO(0) W !,"Completed: ",Y," Closing Tape Device..."
- D ^%ZISC
- K I1,LN,LEN,PG,PSXAM,PSXBEE,PSXIOF,PSXPIOF,PSXPIOST,PSXP,PSXT,PSXTBS
- K PSXTIOF,PSXTPAR,%MT,Y,Z,Z1,ZPC,ZQ1,ZQ,ZZZ,RXCT,BATCT,T1,T2,%
- K %MT,%ZIS,PSXTAPE,C1,CT,I21,I24,PAD,PSXEOT,X,XX,Y,Z
- Q
- ONE ;GET DATA FROM 552.1
- ;** FROM 0,1,2,P NODES **
- ;REC=(1)BAT-REF^(2)STATUS^(3)TRANS D/T^(4)REC D/T^(5)CLOSED D/T
- ;^(6)PROC D/T^(7)START SEQ^(8)END SEQ^(9)TOT ORD^(10)TOT RX'S
- ;^(11)PURGE STAT^(12)RETRANS^(13) BAT-REF^(14)DIV^(15)SITE^(16)SENDER
- S I21=$P(^TMP("PSX",$J,ZZZ),"^") Q:$G(I21)']""
- F I=1:1:6 S $P(REC,"^",I)=$P(^PSX(552.1,I21,0),"^",I)
- S PC=7 F I=1:1:5 S $P(REC,"^",PC)=$P($G(^PSX(552.1,I21,1)),"^",I),PC=PC+1
- F I=1:1:2 S $P(REC,"^",PC)=$P($G(^PSX(552.1,I21,2)),"^",I),PC=PC+1
- F I=1:1:3 S $P(REC,"^",PC)=$P($G(^PSX(552.1,I21,"P")),"^",I),PC=PC+1
- S Z=2 F Z1=1,5,6,7,16,8,9,10,11,19,12,13,2,3,4 D S Z=Z+1
- .S Y=$P(REC,"^",Z),$P(REC,"^",Z)=$$EXTERNAL^DILFD(552.1,Z1,"",Y)
- .;S Y=$P(REC,"^",Z) I $D(^DD(552.1,Z1,0)) S C=$P(^DD(552.1,Z1,0),U,2) D Y^DIQ S $P(REC,"^",Z)=Y
- ;N X,Y S DIC=4,DIC(0)="MNZ",X=+$P(REC,"^",15),X=$E(X,1,3) S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC K DIC ;****DOD L1
- ;S:($D(Y(0,0))) $P(REC,"^",15)=Y(0,0) K X,Y
- N X,Y
- S X=+$P(REC,"^",15),AGNCY="VASTANUM" S:$D(^PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" ;****DOD L1
- S X=$$IEN^XUMF(4,AGNCY,X) ;****DOD L1
- S:(X) $P(REC,"^",15)=$$GET1^DIQ(4,X,.01) K X,Y ;****DOD L1
- S REC="$$REC|"_REC
- K PC,Z,C,Y,I
- CNODE I '$D(^PSX(552.1,I21,3)) G LBL
- F Z=0:0 S Z=$O(^PSX(552.1,I21,3,Z)) Q:'Z S COM(Z)="$$COM|"_$G(^(Z,0))
- ; Get labels printed
- LBL I '$D(^PSX(552.1,I21,4)) G ACK
- S Z1=1,LBL(Z1)="$$LBL|"
- S Z=$O(^PSX(552.1,I21,4,0)) I $G(Z)']"" G ACK
- LBL1 S Y=$P(^PSX(552.1,I21,4,Z,0),"^") X ^DD("DD")
- ;S NAME=$P(^VA(200,$P(^PSX(552.1,I21,4,Z,0),"^",2),0),"^")
- S NAME=$$GET1^DIQ(200,$P(^PSX(552.1,I21,4,Z,0),"^",2),.01)
- I $L(LBL(Z1))+$L(Y)+$L(NAME)<245 S LBL(Z1)=LBL(Z1)_Y_"^"_NAME_"/"
- E S Z1=Z1+1 S LBL(Z1)="$$LBL|"_Y_"^"_NAME_"^"
- S Z=$O(^PSX(552.1,I21,4,Z)) I $G(Z)]"" G LBL1
- ACK I $D(^PSX(552.1,I21,"ACK")) D
- .S ACK="$$ACK|"_$G(^PSX(552.1,I21,"ACK"))
- ; W 552.1 data to tape
- D PSXAT
- BATCH U PSXT W REC S T1=$G(T1)+$L(REC)
- I $D(COM)>1 F Z=0:0 S Z=$O(COM(Z)) Q:'Z U PSXT W COM(Z) S T1=$G(T1)+$L(COM(Z))
- I $D(LBL)>1 F Z=0:0 S Z=$O(LBL(Z)) Q:'Z U PSXT W LBL(Z) S T1=$G(T1)+$L(LBL(Z))
- I $D(ACK)>1 U PSXT W ACK S T1=$G(T1)+$L(ACK)
- ;Print 552.1 data
- S BATCT=$G(BATCT)+1
- ;Disallow further editing of Archived batch
- HEADING U IO(0) I $Y>22 W @PSXIOF S PG=1
- I $G(PG)=1 U IO(0) W !,"TRANSMISSION #",?20,"TOT ORDERS",?36,"TOT Rx's" S PG=$G(PG)+1
- U IO(0) W !,$P($P(REC,"|",2),"^"),?20,$J($P($P(REC,"|",2),"^",9),10),?34,$J($P($P(REC,"|",2),"^",10),10)
- K NAME,Y,Z1,Z
- ; Get info for 552.4
- S I24=$P(^TMP("PSX",$J,ZZZ),"^",2) Q:$G(I24)']""
- S C1=1
- RX F Z=0:0 S Z=$O(^PSX(552.4,I24,1,Z)) Q:'Z D Q:$G(NEWTAPE)=1
- .S REC1=$G(^PSX(552.4,I24,1,Z,0))
- .S REC2=$G(^PSX(552.4,I24,1,Z,2))
- .S ZZ=2 F Z1=1,2,3,4,5,7,8,.02,9,10,11,12 D S ZZ=ZZ+1
- ..S Y=$P(REC1,"^",ZZ),$P(REC1,"^",ZZ)=$$EXTERNAL^DILFD(552.41,Z1,"",Y)
- ..;S Y=$P(REC1,"^",ZZ),C=$P(^DD(552.41,Z1,0),U,2) D Y^DIQ S $P(REC1,"^",ZZ)=Y
- .S ZZ=1 F Z1=13,14,15,16 D S ZZ=ZZ+1
- ..S Y=$P(REC2,"^",ZZ),$P(REC2,"^",ZZ)=$$EXTERNAL^DILFD(552.41,Z1,"",Y)
- ..;S Y=$P(REC2,"^",ZZ) I $D(^DD(552.41,Z1,0)) S C=$P(^DD(552.41,Z1,0),U,2) D Y^DIQ S $P(REC2,"^",ZZ)=Y
- .F ZLOT=0:0 S ZLOT=$O(^PSX(552.4,I24,1,Z,1,ZLOT)) Q:($G(ZLOT)']"") D
- ..S Y=$P($G(^PSX(552.4,I24,1,Z,1,ZLOT,0)),"^",2) X ^DD("DD")
- ..S LOT=$G(LOT)_$P($G(^PSX(552.4,I24,1,Z,1,ZLOT,0)),"^")_"^"_Y_"/"
- .; I EOT detected, reset batch info and rewrite to new tape
- .D PSXAT I $G(NEWTAPE)=1 Q
- .U PSXT W "$$RX,"_C1_"|"_REC1 S RXCT=$G(RXCT)+1,T2=$G(T2)+$L(REC1)
- .U PSXT W "$$ZX,"_C1_"|"_REC2 S T2=$G(T2)+$L(REC1)
- .I $G(LOT)]"" U PSXT W "$$LOT,"_C1_"|"_LOT S T2=$G(T2)+$L(LOT)
- .I $G(PSXP)]"" D RX^PSXARC2
- .K REC1,REC2,ZZ,ZLOT,LOT,Z1,Y,C S C1=C1+1
- I $G(NEWTAPE)=1 K NEWTAPE,Z G BATCH
- S ^PSX(552.4,I24,-9)=""
- S NAME=$$GET1^DIQ(200,DUZ,.01)
- K DD,DO
- S DIC="^PSXARC(",DIC("DR")="1////"_PSXTAPE_";2////"_DT_";3////"_NAME
- S DIC(0)="MZ",X=$P(^TMP("PSX",$J,ZZZ),"^",3)
- D FILE^DICN K DIC,X,NAME,DD,DO
- I $G(Y)<0 W !!,"An error has been encountered in the archive file for transmission number ",$P(^TMP("PSX",$J,ZZZ),"^",3)
- K REC,COM,LBL,ACK,NAME,Y,Z1,Z
- NEWTAPE Q
- PSXAT ;CHECK FOR EOT RETURN PSXEOT=1 IF EOT FOUND
- U PSXT S PSXEOT=0 X ^%ZOSF("EOT") I Y D EOT S PSXEOT=1
- Q
- EOT U IO(0) W !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape" U PSXT W ^%ZOSF("REW")
- READ U IO(0) W !?5,"Type <CR> to continue" R XX:DTIME I '$T G READ
- S PSXTAPE=$E(PSXTAPE,1,5)_$E(PSXTAPE,6)+1
- HDR U PSXT W "$$HDR|CMOP MASTER ARCHIVE^"_PSXTAPE
- S NEWTAPE=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXARC1 5584 printed Dec 13, 2024@01:43:21 Page 2
- PSXARC1 ;BIR/HTW-Gather Data to Archive ;02 Aug 2001 9:57 AM
- +1 ;;2.0;CMOP;**26,38**;11 Apr 97
- +2 ; Reference to file #200 supported by DBIA 10060
- +3 SET (LN,PG,CT)=1
- SET (X,LEN,BATCT,RXCT)=0
- SET PAD=" "
- TAPEHDR USE PSXT
- WRITE "$$HDR|CMOP MASTER ARCHIVE^"_PSXTAPE
- +1 DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- KILL %
- +2 USE IO(0)
- WRITE @PSXIOF,?10,"CMOP MASTER DATABASE ARCHIVE",?45,Y
- MAIN ;
- +1 USE IO(0)
- WRITE !!,"Recording data on tape # ",PSXTAPE,". Write this number on the tape label!!",!!
- +2 FOR ZZZ=0:0
- SET ZZZ=$ORDER(^TMP("PSX",$JOB,ZZZ))
- if 'ZZZ
- QUIT
- DO ONE
- SET ^PSX(552.1,I21,-9)=""
- +3 USE IO(0)
- WRITE !!,"Total # of Transmissions Archived: ",$GET(BATCT)
- +4 USE IO(0)
- WRITE !,"Total # of Rx's Archived : ",$GET(RXCT)
- +5 USE IO(0)
- WRITE !,"Total Bytes Archived : ",$GET(T1)+$GET(T2)
- +6 DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- +7 USE IO(0)
- WRITE !,"Completed: ",Y," Closing Tape Device..."
- +8 DO ^%ZISC
- +9 KILL I1,LN,LEN,PG,PSXAM,PSXBEE,PSXIOF,PSXPIOF,PSXPIOST,PSXP,PSXT,PSXTBS
- +10 KILL PSXTIOF,PSXTPAR,%MT,Y,Z,Z1,ZPC,ZQ1,ZQ,ZZZ,RXCT,BATCT,T1,T2,%
- +11 KILL %MT,%ZIS,PSXTAPE,C1,CT,I21,I24,PAD,PSXEOT,X,XX,Y,Z
- +12 QUIT
- ONE ;GET DATA FROM 552.1
- +1 ;** FROM 0,1,2,P NODES **
- +2 ;REC=(1)BAT-REF^(2)STATUS^(3)TRANS D/T^(4)REC D/T^(5)CLOSED D/T
- +3 ;^(6)PROC D/T^(7)START SEQ^(8)END SEQ^(9)TOT ORD^(10)TOT RX'S
- +4 ;^(11)PURGE STAT^(12)RETRANS^(13) BAT-REF^(14)DIV^(15)SITE^(16)SENDER
- +5 SET I21=$PIECE(^TMP("PSX",$JOB,ZZZ),"^")
- if $GET(I21)']""
- QUIT
- +6 FOR I=1:1:6
- SET $PIECE(REC,"^",I)=$PIECE(^PSX(552.1,I21,0),"^",I)
- +7 SET PC=7
- FOR I=1:1:5
- SET $PIECE(REC,"^",PC)=$PIECE($GET(^PSX(552.1,I21,1)),"^",I)
- SET PC=PC+1
- +8 FOR I=1:1:2
- SET $PIECE(REC,"^",PC)=$PIECE($GET(^PSX(552.1,I21,2)),"^",I)
- SET PC=PC+1
- +9 FOR I=1:1:3
- SET $PIECE(REC,"^",PC)=$PIECE($GET(^PSX(552.1,I21,"P")),"^",I)
- SET PC=PC+1
- +10 SET Z=2
- FOR Z1=1,5,6,7,16,8,9,10,11,19,12,13,2,3,4
- Begin DoDot:1
- +11 SET Y=$PIECE(REC,"^",Z)
- SET $PIECE(REC,"^",Z)=$$EXTERNAL^DILFD(552.1,Z1,"",Y)
- +12 ;S Y=$P(REC,"^",Z) I $D(^DD(552.1,Z1,0)) S C=$P(^DD(552.1,Z1,0),U,2) D Y^DIQ S $P(REC,"^",Z)=Y
- End DoDot:1
- SET Z=Z+1
- +13 ;N X,Y S DIC=4,DIC(0)="MNZ",X=+$P(REC,"^",15),X=$E(X,1,3) S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC K DIC ;****DOD L1
- +14 ;S:($D(Y(0,0))) $P(REC,"^",15)=Y(0,0) K X,Y
- +15 NEW X,Y
- +16 ;****DOD L1
- SET X=+$PIECE(REC,"^",15)
- SET AGNCY="VASTANUM"
- if $DATA(^PSX(552,"D",X))
- SET X=$EXTRACT(X,2,99)
- SET AGNCY="DMIS"
- +17 ;****DOD L1
- SET X=$$IEN^XUMF(4,AGNCY,X)
- +18 ;****DOD L1
- if (X)
- SET $PIECE(REC,"^",15)=$$GET1^DIQ(4,X,.01)
- KILL X,Y
- +19 SET REC="$$REC|"_REC
- +20 KILL PC,Z,C,Y,I
- CNODE IF '$DATA(^PSX(552.1,I21,3))
- GOTO LBL
- +1 FOR Z=0:0
- SET Z=$ORDER(^PSX(552.1,I21,3,Z))
- if 'Z
- QUIT
- SET COM(Z)="$$COM|"_$GET(^(Z,0))
- +2 ; Get labels printed
- LBL IF '$DATA(^PSX(552.1,I21,4))
- GOTO ACK
- +1 SET Z1=1
- SET LBL(Z1)="$$LBL|"
- +2 SET Z=$ORDER(^PSX(552.1,I21,4,0))
- IF $GET(Z)']""
- GOTO ACK
- LBL1 SET Y=$PIECE(^PSX(552.1,I21,4,Z,0),"^")
- XECUTE ^DD("DD")
- +1 ;S NAME=$P(^VA(200,$P(^PSX(552.1,I21,4,Z,0),"^",2),0),"^")
- +2 SET NAME=$$GET1^DIQ(200,$PIECE(^PSX(552.1,I21,4,Z,0),"^",2),.01)
- +3 IF $LENGTH(LBL(Z1))+$LENGTH(Y)+$LENGTH(NAME)<245
- SET LBL(Z1)=LBL(Z1)_Y_"^"_NAME_"/"
- +4 IF '$TEST
- SET Z1=Z1+1
- SET LBL(Z1)="$$LBL|"_Y_"^"_NAME_"^"
- +5 SET Z=$ORDER(^PSX(552.1,I21,4,Z))
- IF $GET(Z)]""
- GOTO LBL1
- ACK IF $DATA(^PSX(552.1,I21,"ACK"))
- Begin DoDot:1
- +1 SET ACK="$$ACK|"_$GET(^PSX(552.1,I21,"ACK"))
- End DoDot:1
- +2 ; W 552.1 data to tape
- +3 DO PSXAT
- BATCH USE PSXT
- WRITE REC
- SET T1=$GET(T1)+$LENGTH(REC)
- +1 IF $DATA(COM)>1
- FOR Z=0:0
- SET Z=$ORDER(COM(Z))
- if 'Z
- QUIT
- USE PSXT
- WRITE COM(Z)
- SET T1=$GET(T1)+$LENGTH(COM(Z))
- +2 IF $DATA(LBL)>1
- FOR Z=0:0
- SET Z=$ORDER(LBL(Z))
- if 'Z
- QUIT
- USE PSXT
- WRITE LBL(Z)
- SET T1=$GET(T1)+$LENGTH(LBL(Z))
- +3 IF $DATA(ACK)>1
- USE PSXT
- WRITE ACK
- SET T1=$GET(T1)+$LENGTH(ACK)
- +4 ;Print 552.1 data
- +5 SET BATCT=$GET(BATCT)+1
- +6 ;Disallow further editing of Archived batch
- HEADING USE IO(0)
- IF $Y>22
- WRITE @PSXIOF
- SET PG=1
- +1 IF $GET(PG)=1
- USE IO(0)
- WRITE !,"TRANSMISSION #",?20,"TOT ORDERS",?36,"TOT Rx's"
- SET PG=$GET(PG)+1
- +2 USE IO(0)
- WRITE !,$PIECE($PIECE(REC,"|",2),"^"),?20,$JUSTIFY($PIECE($PIECE(REC,"|",2),"^",9),10),?34,$JUSTIFY($PIECE($PIECE(REC,"|",2),"^",10),10)
- +3 KILL NAME,Y,Z1,Z
- +4 ; Get info for 552.4
- +5 SET I24=$PIECE(^TMP("PSX",$JOB,ZZZ),"^",2)
- if $GET(I24)']""
- QUIT
- +6 SET C1=1
- RX FOR Z=0:0
- SET Z=$ORDER(^PSX(552.4,I24,1,Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +1 SET REC1=$GET(^PSX(552.4,I24,1,Z,0))
- +2 SET REC2=$GET(^PSX(552.4,I24,1,Z,2))
- +3 SET ZZ=2
- FOR Z1=1,2,3,4,5,7,8,.02,9,10,11,12
- Begin DoDot:2
- +4 SET Y=$PIECE(REC1,"^",ZZ)
- SET $PIECE(REC1,"^",ZZ)=$$EXTERNAL^DILFD(552.41,Z1,"",Y)
- +5 ;S Y=$P(REC1,"^",ZZ),C=$P(^DD(552.41,Z1,0),U,2) D Y^DIQ S $P(REC1,"^",ZZ)=Y
- End DoDot:2
- SET ZZ=ZZ+1
- +6 SET ZZ=1
- FOR Z1=13,14,15,16
- Begin DoDot:2
- +7 SET Y=$PIECE(REC2,"^",ZZ)
- SET $PIECE(REC2,"^",ZZ)=$$EXTERNAL^DILFD(552.41,Z1,"",Y)
- +8 ;S Y=$P(REC2,"^",ZZ) I $D(^DD(552.41,Z1,0)) S C=$P(^DD(552.41,Z1,0),U,2) D Y^DIQ S $P(REC2,"^",ZZ)=Y
- End DoDot:2
- SET ZZ=ZZ+1
- +9 FOR ZLOT=0:0
- SET ZLOT=$ORDER(^PSX(552.4,I24,1,Z,1,ZLOT))
- if ($GET(ZLOT)']"")
- QUIT
- Begin DoDot:2
- +10 SET Y=$PIECE($GET(^PSX(552.4,I24,1,Z,1,ZLOT,0)),"^",2)
- XECUTE ^DD("DD")
- +11 SET LOT=$GET(LOT)_$PIECE($GET(^PSX(552.4,I24,1,Z,1,ZLOT,0)),"^")_"^"_Y_"/"
- End DoDot:2
- +12 ; I EOT detected, reset batch info and rewrite to new tape
- +13 DO PSXAT
- IF $GET(NEWTAPE)=1
- QUIT
- +14 USE PSXT
- WRITE "$$RX,"_C1_"|"_REC1
- SET RXCT=$GET(RXCT)+1
- SET T2=$GET(T2)+$LENGTH(REC1)
- +15 USE PSXT
- WRITE "$$ZX,"_C1_"|"_REC2
- SET T2=$GET(T2)+$LENGTH(REC1)
- +16 IF $GET(LOT)]""
- USE PSXT
- WRITE "$$LOT,"_C1_"|"_LOT
- SET T2=$GET(T2)+$LENGTH(LOT)
- +17 IF $GET(PSXP)]""
- DO RX^PSXARC2
- +18 KILL REC1,REC2,ZZ,ZLOT,LOT,Z1,Y,C
- SET C1=C1+1
- End DoDot:1
- if $GET(NEWTAPE)=1
- QUIT
- +19 IF $GET(NEWTAPE)=1
- KILL NEWTAPE,Z
- GOTO BATCH
- +20 SET ^PSX(552.4,I24,-9)=""
- +21 SET NAME=$$GET1^DIQ(200,DUZ,.01)
- +22 KILL DD,DO
- +23 SET DIC="^PSXARC("
- SET DIC("DR")="1////"_PSXTAPE_";2////"_DT_";3////"_NAME
- +24 SET DIC(0)="MZ"
- SET X=$PIECE(^TMP("PSX",$JOB,ZZZ),"^",3)
- +25 DO FILE^DICN
- KILL DIC,X,NAME,DD,DO
- +26 IF $GET(Y)<0
- WRITE !!,"An error has been encountered in the archive file for transmission number ",$PIECE(^TMP("PSX",$JOB,ZZZ),"^",3)
- +27 KILL REC,COM,LBL,ACK,NAME,Y,Z1,Z
- NEWTAPE QUIT
- PSXAT ;CHECK FOR EOT RETURN PSXEOT=1 IF EOT FOUND
- +1 USE PSXT
- SET PSXEOT=0
- XECUTE ^%ZOSF("EOT")
- IF Y
- DO EOT
- SET PSXEOT=1
- +2 QUIT
- EOT USE IO(0)
- WRITE !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape"
- USE PSXT
- WRITE ^%ZOSF("REW")
- READ USE IO(0)
- WRITE !?5,"Type <CR> to continue"
- READ XX:DTIME
- IF '$TEST
- GOTO READ
- +1 SET PSXTAPE=$EXTRACT(PSXTAPE,1,5)_$EXTRACT(PSXTAPE,6)+1
- HDR USE PSXT
- WRITE "$$HDR|CMOP MASTER ARCHIVE^"_PSXTAPE
- +1 SET NEWTAPE=1
- +2 QUIT