DGPTAPA ;MTC/ALB - PTF Archive Utilities; 10-14-92
;;5.3;Registration;;Aug 13, 1993
;
ARC ;-- entry point to Archive PTF records
N DGTMP,REGEN
;
;-- set re-generation flag to yes
S REGEN=1
;-- get template to archive
D SEL^VALM2 I '$D(VALMY) G ARCQ
S DGTMP=$O(^TMP("ARCPTF",$J,"AP LIST","REC",+$O(VALMY(0)),0))
;
;-- if data is already purged then exit
I $P(^DGP(45.62,DGTMP,0),U,7) W !,">>> PTF Archived Data Already Purged..." H 2 G ARCQ
;-- find out if archive data exist
I $$MKARC(DGTMP,.REGEN) D
.;-- do archive to device
. I $$WR(DGTMP,REGEN) D
..;-- update history file
.. D ADDARC(DGTMP)
;
ARCQ Q
;
ADDARC(TEMP) ;-- This function will add archive date, user and status
;
; INPUT : TEMP - IFN of the History File to update
;
N SRTMP
;-- if no A/P template exit
I '$D(^DGP(45.62,TEMP,0)) G ADDARCQ
;-- new/revise archive data A/P template archive data
W !,">>> Adding Archive data to PTF Archive/Purge History entry."
S DA=TEMP,DIE="^DGP(45.62,",DR=".02////^S X=DUZ;.03///NOW;.04///1"
D ^DIE
ADDARCQ ;
Q
;
ARCEX ;-- exit point from protocol
D TMPINT^DGPTLMU2
S VALMBCK="R"
Q
;
MKARC(DGTMP,REGEN) ;-- this function will create the word process field that contains the
; archive data if one does not exists. If a field already exist then
; the data will be deleted and the new field will be created.
;
; INPUT : DGTMP - A/P Template
; REGEN - flag to indicate if re-gen of data is required
; OUTPUT : 1 - ok continue
; 0 - don't continue
;
N DATE,EXIST
S EXIST=1
;--if data has been purged, if so exit
G:$P($G(^DGP(45.62,DGTMP,0)),U,7) MKARCQ
;--check if archive data already exists
I $G(^DGP(45.62,DGTMP,100,0))'="" S EXIST=$$CHDATA G:EXIST<0 MKARCQ
;-- if regenerate delete old data, set flag
I EXIST D
. S DR="100///@",DA=DGTMP,DIE="^DGP(45.62," D ^DIE K DA,DR,DIE
. S REGEN=1
;-- set flag NOT to regenerate
I 'EXIST S REGEN=0
S EXIST=1
MKARCQ Q EXIST
;
CHDATA() ;-- if data already exists in WP field ask if should be purged
; OUTPUT : 1 - ok continue
; 0 - don't continue
; -1 - user enters a "^"
N EXIST
S DIR(0)="Y",DIR("A")="Archive Data already exists. Should I re-generate the Archive data",DIR("B")="NO" D ^DIR
S EXIST=$S($D(DIRUT):-1,Y:1,1:0)
K DIR
Q EXIST
CHECK ;
S Y=$$STATUS^DGPTLMU2(DGTMP)
Q
;
WR(DGTMP,REGEN) ;-- this function will write the archived data out to a sequential
; device.
; INPUT : DGTMP - Active PTF A/P template
; REGEN - regeneration flag
; OUTPUT : 1 - ok continue
; 0 - don't continue
;
N RESULT
S RESULT=1
W !!,*7,">>> Select Device for Archiving PTF Data."
S %ZIS="Q" D ^%ZIS I POP S RESULT=0 G WRQ
I $D(IO("Q")) D G WRQ
. S ZTRTN="WRITEM^DGPTAPA",ZTDESC="PTF A/P Archive",ZTSAVE("DGTMP")="",ZTSAVE("REGEN")=""
. D ^%ZTLOAD D HOME^%ZIS K IO("Q")
D WRITEM
WRQ ;
Q RESULT
;
WRITEM ;-- loop thru write archive data
N I,X,DGPTF
U IO
;-- check if archive data should be built
I REGEN D BLDAD(DGTMP)
;-- write archived data to a device
S I=0 F S I=$O(^DGP(45.62,DGTMP,100,I)) Q:'I D
. S X=$G(^DGP(45.62,DGTMP,100,I,0))
. W:X]"" X,!
D ^%ZISC
WRITEMQ ;
Q
;
BLDAD(DGTMP) ;-- This function will load the Archive data into the wp
; field in the A/P template.
;
; INPUT : DGTMP - A/P Template
;
N SRTMP,DGPTF,DATE
;-- delete any data in wp field
I $D(DGP(45.62,DGTMP,100)) D
. S DR="100///@",DA=DGTMP,DIE="^DGP(45.62," D ^DIE K DA,DR,DIE
;-- load header
S DATE="$PTF Records Selected from "_$$FTIME^VALM1($P(^DGP(45.62,DGTMP,0),U,10))_" thru "_$$FTIME^VALM1($P(^DGP(45.62,DGTMP,0),U,11))_"."
S DR="100///^S X=DATE",DA=DGTMP,DIE="^DGP(45.62," D ^DIE K DA,DR,DIE
;-- add generic header to wp field
D MKHEAD^DGPTAPA4
;-- archive selected records
S SRTMP=$P(^DGP(45.62,DGTMP,0),U,8),DGPTF=""
F S DGPTF=$O(^DIBT(SRTMP,1,DGPTF)) Q:'DGPTF D ARINT^DGPTAPA1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPA 3997 printed Jan 18, 2025@03:52:17 Page 2
DGPTAPA ;MTC/ALB - PTF Archive Utilities; 10-14-92
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
ARC ;-- entry point to Archive PTF records
+1 NEW DGTMP,REGEN
+2 ;
+3 ;-- set re-generation flag to yes
+4 SET REGEN=1
+5 ;-- get template to archive
+6 DO SEL^VALM2
IF '$DATA(VALMY)
GOTO ARCQ
+7 SET DGTMP=$ORDER(^TMP("ARCPTF",$JOB,"AP LIST","REC",+$ORDER(VALMY(0)),0))
+8 ;
+9 ;-- if data is already purged then exit
+10 IF $PIECE(^DGP(45.62,DGTMP,0),U,7)
WRITE !,">>> PTF Archived Data Already Purged..."
HANG 2
GOTO ARCQ
+11 ;-- find out if archive data exist
+12 IF $$MKARC(DGTMP,.REGEN)
Begin DoDot:1
+13 ;-- do archive to device
+14 IF $$WR(DGTMP,REGEN)
Begin DoDot:2
+15 ;-- update history file
+16 DO ADDARC(DGTMP)
End DoDot:2
End DoDot:1
+17 ;
ARCQ QUIT
+1 ;
ADDARC(TEMP) ;-- This function will add archive date, user and status
+1 ;
+2 ; INPUT : TEMP - IFN of the History File to update
+3 ;
+4 NEW SRTMP
+5 ;-- if no A/P template exit
+6 IF '$DATA(^DGP(45.62,TEMP,0))
GOTO ADDARCQ
+7 ;-- new/revise archive data A/P template archive data
+8 WRITE !,">>> Adding Archive data to PTF Archive/Purge History entry."
+9 SET DA=TEMP
SET DIE="^DGP(45.62,"
SET DR=".02////^S X=DUZ;.03///NOW;.04///1"
+10 DO ^DIE
ADDARCQ ;
+1 QUIT
+2 ;
ARCEX ;-- exit point from protocol
+1 DO TMPINT^DGPTLMU2
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
MKARC(DGTMP,REGEN) ;-- this function will create the word process field that contains the
+1 ; archive data if one does not exists. If a field already exist then
+2 ; the data will be deleted and the new field will be created.
+3 ;
+4 ; INPUT : DGTMP - A/P Template
+5 ; REGEN - flag to indicate if re-gen of data is required
+6 ; OUTPUT : 1 - ok continue
+7 ; 0 - don't continue
+8 ;
+9 NEW DATE,EXIST
+10 SET EXIST=1
+11 ;--if data has been purged, if so exit
+12 if $PIECE($GET(^DGP(45.62,DGTMP,0)),U,7)
GOTO MKARCQ
+13 ;--check if archive data already exists
+14 IF $GET(^DGP(45.62,DGTMP,100,0))'=""
SET EXIST=$$CHDATA
if EXIST<0
GOTO MKARCQ
+15 ;-- if regenerate delete old data, set flag
+16 IF EXIST
Begin DoDot:1
+17 SET DR="100///@"
SET DA=DGTMP
SET DIE="^DGP(45.62,"
DO ^DIE
KILL DA,DR,DIE
+18 SET REGEN=1
End DoDot:1
+19 ;-- set flag NOT to regenerate
+20 IF 'EXIST
SET REGEN=0
+21 SET EXIST=1
MKARCQ QUIT EXIST
+1 ;
CHDATA() ;-- if data already exists in WP field ask if should be purged
+1 ; OUTPUT : 1 - ok continue
+2 ; 0 - don't continue
+3 ; -1 - user enters a "^"
+4 NEW EXIST
+5 SET DIR(0)="Y"
SET DIR("A")="Archive Data already exists. Should I re-generate the Archive data"
SET DIR("B")="NO"
DO ^DIR
+6 SET EXIST=$SELECT($DATA(DIRUT):-1,Y:1,1:0)
+7 KILL DIR
+8 QUIT EXIST
CHECK ;
+1 SET Y=$$STATUS^DGPTLMU2(DGTMP)
+2 QUIT
+3 ;
WR(DGTMP,REGEN) ;-- this function will write the archived data out to a sequential
+1 ; device.
+2 ; INPUT : DGTMP - Active PTF A/P template
+3 ; REGEN - regeneration flag
+4 ; OUTPUT : 1 - ok continue
+5 ; 0 - don't continue
+6 ;
+7 NEW RESULT
+8 SET RESULT=1
+9 WRITE !!,*7,">>> Select Device for Archiving PTF Data."
+10 SET %ZIS="Q"
DO ^%ZIS
IF POP
SET RESULT=0
GOTO WRQ
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTRTN="WRITEM^DGPTAPA"
SET ZTDESC="PTF A/P Archive"
SET ZTSAVE("DGTMP")=""
SET ZTSAVE("REGEN")=""
+13 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
GOTO WRQ
+14 DO WRITEM
WRQ ;
+1 QUIT RESULT
+2 ;
WRITEM ;-- loop thru write archive data
+1 NEW I,X,DGPTF
+2 USE IO
+3 ;-- check if archive data should be built
+4 IF REGEN
DO BLDAD(DGTMP)
+5 ;-- write archived data to a device
+6 SET I=0
FOR
SET I=$ORDER(^DGP(45.62,DGTMP,100,I))
if 'I
QUIT
Begin DoDot:1
+7 SET X=$GET(^DGP(45.62,DGTMP,100,I,0))
+8 if X]""
WRITE X,!
End DoDot:1
+9 DO ^%ZISC
WRITEMQ ;
+1 QUIT
+2 ;
BLDAD(DGTMP) ;-- This function will load the Archive data into the wp
+1 ; field in the A/P template.
+2 ;
+3 ; INPUT : DGTMP - A/P Template
+4 ;
+5 NEW SRTMP,DGPTF,DATE
+6 ;-- delete any data in wp field
+7 IF $DATA(DGP(45.62,DGTMP,100))
Begin DoDot:1
+8 SET DR="100///@"
SET DA=DGTMP
SET DIE="^DGP(45.62,"
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+9 ;-- load header
+10 SET DATE="$PTF Records Selected from "_$$FTIME^VALM1($PIECE(^DGP(45.62,DGTMP,0),U,10))_" thru "_$$FTIME^VALM1($PIECE(^DGP(45.62,DGTMP,0),U,11))_"."
+11 SET DR="100///^S X=DATE"
SET DA=DGTMP
SET DIE="^DGP(45.62,"
DO ^DIE
KILL DA,DR,DIE
+12 ;-- add generic header to wp field
+13 DO MKHEAD^DGPTAPA4
+14 ;-- archive selected records
+15 SET SRTMP=$PIECE(^DGP(45.62,DGTMP,0),U,8)
SET DGPTF=""
+16 FOR
SET DGPTF=$ORDER(^DIBT(SRTMP,1,DGPTF))
if 'DGPTF
QUIT
DO ARINT^DGPTAPA1
+17 QUIT
+18 ;
