- 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 Feb 19, 2025@00:11:04 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