DIARCALC ;SFISC/TKW,WISC/CAP-ARCHIVING Variables Doc / Misc Calc.;06:10 PM 5 Dec 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;COMPUTE BOUNDARIES
FROM ;SELECT FROM VALUE 4 SORT
S X="F" D G
FIRST I $D(DIARS) S:A="" A=$P(DIARS,U,2) S:A="" A=$$EZBLD^DIALOG(7070) G Q ;**CCO/NI 'FIRST'
D H Q:X="" S DIARS=Y_U_X Q
TO ;SELECT TO VALUE 4 SORT
S X="T" D G
LAST I $D(DIARE) S:A="" A=$P(DIARE,U,2) S:A="" A=$$EZBLD^DIALOG(7071) G Q ;**CCO/NI 'LAST'
D H Q:X="" S DIARE=Y_U_X Q
G S DIART=L,L=0 I $D(DIPP(DJ,X)) S A=$P(DIPP(DJ,X),U,2) Q
I $D(DPP(DJ,X)) S A=$P(DPP(DJ,X),U,2) Q
S A="" Q
H ;
S %=X,%1=DISV
I +%1,$D(^DIBT(%1,2,DJ,%)) S (X,%2)=$P(^(%),U,2) I "z"'[X
EGP E S %2=$S(%="T":$$EZBLD^DIALOG(7071),1:$$EZBLD^DIALOG(7070)),X="" ;**CCO/NI 'FIRST' OR 'LAST'
I X="",'$D(DIAR) S A=%2,L=DIART G Q
D CK:X'=""
S L=DIART,A=$S(%="F"&(X]%2):X,%="T"&(%2]X)&(X'=""):X,A'="":A,1:%2)
Q K %,%1,%2,DIART Q
;
NEW ;SET UP INITIAL ARCHIVAL ACTIVITY
D NOW^%DTC
S X=$P(^DIAR(1.11,0),U,3) F X=X:1 L +^DIAR(1.11,X):0 Q:$T&'$D(^(X)) L -^DIAR(1.11,X)
S Z="1////"_DIART_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";30////"_DIARF_";13////"_DIAR_";14////"_%_$S($D(^VA(200)):";15////"_DUZ,1:"")_";16////"_$S($D(DIAX):1,1:0)
I $D(DIARF0) S Z=Z_";31////"_DIARF0
S DINUM=X,DIC("DR")=Z
S DIC="^DIAR(1.11,",DIC(0)="EF"
K DO D FILE^DICN S DIARC=+Y K DR
Q
;
CK S DIART=%_U_%2_U_A D CK^DIP12
S %=$P(DIART,U,1),%2=$P(DIART,U,2),A=$P(DIART,U,3) Q
VAR ;
;DIAR0 = List of human readable conditions from ^DOPT("DIS" in ^ pieces
;DIARC = Internal record number of Archival Activity
;DIARD = Array of information from default package archival search
; template for this file. (Created in DIAR0)
;DIARDC= Number of default conditions
;DIARE = To value in DIP sort questions
;DIARF = Internal number of file being archived
;DIARF0= Subfile List or DIAR/DIBT INDEX
;DIARI = SEARCH TEMPLATE USED
;DIARF1=Level # that search is on
;DIARP = Internal record no. of Filegram template
;DIARS = Temporary value / From value in DIP sort questions
;DIART = Temporary storage variable
;DIARU = Internal number of Select Criteria Template
;DIARST = Archival Activity upon entry to archival option
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARCALC 2506 printed Dec 13, 2024@02:44:49 Page 2
DIARCALC ;SFISC/TKW,WISC/CAP-ARCHIVING Variables Doc / Misc Calc.;06:10 PM 5 Dec 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;COMPUTE BOUNDARIES
FROM ;SELECT FROM VALUE 4 SORT
+1 SET X="F"
DO G
FIRST ;**CCO/NI 'FIRST'
IF $DATA(DIARS)
if A=""
SET A=$PIECE(DIARS,U,2)
if A=""
SET A=$$EZBLD^DIALOG(7070)
GOTO Q
+1 DO H
if X=""
QUIT
SET DIARS=Y_U_X
QUIT
TO ;SELECT TO VALUE 4 SORT
+1 SET X="T"
DO G
LAST ;**CCO/NI 'LAST'
IF $DATA(DIARE)
if A=""
SET A=$PIECE(DIARE,U,2)
if A=""
SET A=$$EZBLD^DIALOG(7071)
GOTO Q
+1 DO H
if X=""
QUIT
SET DIARE=Y_U_X
QUIT
G SET DIART=L
SET L=0
IF $DATA(DIPP(DJ,X))
SET A=$PIECE(DIPP(DJ,X),U,2)
QUIT
+1 IF $DATA(DPP(DJ,X))
SET A=$PIECE(DPP(DJ,X),U,2)
QUIT
+2 SET A=""
QUIT
H ;
+1 SET %=X
SET %1=DISV
+2 IF +%1
IF $DATA(^DIBT(%1,2,DJ,%))
SET (X,%2)=$PIECE(^(%),U,2)
IF "z"'[X
EGP ;**CCO/NI 'FIRST' OR 'LAST'
IF '$TEST
SET %2=$SELECT(%="T":$$EZBLD^DIALOG(7071),1:$$EZBLD^DIALOG(7070))
SET X=""
+1 IF X=""
IF '$DATA(DIAR)
SET A=%2
SET L=DIART
GOTO Q
+2 if X'=""
DO CK
+3 SET L=DIART
SET A=$SELECT(%="F"&(X]%2):X,%="T"&(%2]X)&(X'=""):X,A'="":A,1:%2)
Q KILL %,%1,%2,DIART
QUIT
+1 ;
NEW ;SET UP INITIAL ARCHIVAL ACTIVITY
+1 DO NOW^%DTC
+2 SET X=$PIECE(^DIAR(1.11,0),U,3)
FOR X=X:1
LOCK +^DIAR(1.11,X):0
if $TEST&'$DATA(^(X))
QUIT
LOCK -^DIAR(1.11,X)
+3 SET Z="1////"_DIART_";4////"_DT_$SELECT($DATA(^VA(200)):";8////"_DUZ,1:"")_";30////"_DIARF_";13////"_DIAR_";14////"_%_$SELECT($DATA(^VA(200)):";15////"_DUZ,1:"")_";16////"_$SELECT($DATA(DIAX):1,1:0)
+4 IF $DATA(DIARF0)
SET Z=Z_";31////"_DIARF0
+5 SET DINUM=X
SET DIC("DR")=Z
+6 SET DIC="^DIAR(1.11,"
SET DIC(0)="EF"
+7 KILL DO
DO FILE^DICN
SET DIARC=+Y
KILL DR
+8 QUIT
+9 ;
CK SET DIART=%_U_%2_U_A
DO CK^DIP12
+1 SET %=$PIECE(DIART,U,1)
SET %2=$PIECE(DIART,U,2)
SET A=$PIECE(DIART,U,3)
QUIT
VAR ;
+1 ;DIAR0 = List of human readable conditions from ^DOPT("DIS" in ^ pieces
+2 ;DIARC = Internal record number of Archival Activity
+3 ;DIARD = Array of information from default package archival search
+4 ; template for this file. (Created in DIAR0)
+5 ;DIARDC= Number of default conditions
+6 ;DIARE = To value in DIP sort questions
+7 ;DIARF = Internal number of file being archived
+8 ;DIARF0= Subfile List or DIAR/DIBT INDEX
+9 ;DIARI = SEARCH TEMPLATE USED
+10 ;DIARF1=Level # that search is on
+11 ;DIARP = Internal record no. of Filegram template
+12 ;DIARS = Temporary value / From value in DIP sort questions
+13 ;DIART = Temporary storage variable
+14 ;DIARU = Internal number of Select Criteria Template
+15 ;DIARST = Archival Activity upon entry to archival option
