DIOZ ;SFISC/TKW - COMPILED SORT TEMPLATE ;30NOV2012
;;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.
;
ENCU ;MARK A SORT TEMPLATE FOR ROUTINE COMPILATION
I $G(DUZ(0))'="@" W !,$C(7),$$EZBLD^DIALOG(101) Q
EN1 N DDH,DIC,DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y,DIOZ
; NB: next 2 lines same in ENC. Need to make shared.
D OS^DII:'$D(DISYS)
I $G(^DD("OS",DISYS,"ZS"))="" D BLD^DIALOG(820) G QSV
D DIC Q:Y<0 S DIOZ=+Y
S DIR(0)="Y"
I $G(^DIBT(+Y,"ROU"))="" D Q
.D BLD^DIALOG(8029,$$EZBLD^DIALOG(8035),"","DIR(""A"")")
.S DIR("B")="YES" D BLD^DIALOG(9014,"","","DIR(""?"")"),^DIR Q:'Y
.S ^DIBT(DIOZ,"ROU")="^DISZ",^("ROUOLD")="DISZ"
.W !!,$C(7),DIR("?",2),!,DIR("?")
.Q
S X(1)=$$EZBLD^DIALOG(8035),X(2)="DISZ" D BLD^DIALOG(8028,.X,"","DIR(""A"")")
S DIR("B")="NO" D BLD^DIALOG(9019,"","","DIR(""?"")"),^DIR Q:'Y
K ^DIBT(DIOZ,"ROU")
W !!,$C(7),DIR("?",2),!,DIR("?")
Q
;
DIC S DIC="^DIBT(",DIC(0)="AEIQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,""Compiled"""
S DIC("S")="I '$P(^(0),U,8),Y'<1,$O(^DIBT(+Y,2,0))"
D ^DIC Q
;
ENC ;CREATE COMPILED SORT ROUTINE
; NB: next 2 lines same in EN. Need to make shared.
D OS^DII:'$D(DISYS)
I $G(^DD("OS",DISYS,"ZS"))="" D BLD^DIALOG(820) G QSV
I $O(^TMP("DIBTC",$J,""))="" D BLD^DIALOG(1501) G QSV
N %,%H,%I,DIROUT,DIRUT,DTOUT,DUOUT,DRN,I,J,K,X,Y,DIR
D NEW G:$D(DIERR) QSV
S K=2,I="" F S I=$O(^TMP("DIBTC",$J,I)) Q:I="" F J=0:0 S J=$O(^TMP("DIBTC",$J,I,J)) Q:'J S X=^(J) I X]"" S K=K+1,^UTILITY($J,0,K)=X
F I=1:1 S X=$P($T(TXT+I),";",3) Q:X="" S K=K+1,^UTILITY($J,0,K)=X
S X=$P(DIBTPGM,U,2) X ^DD("OS",DISYS,"ZS")
K ^TMP("DIBTC",$J)
Q
;
NEW I DIBTPGM'?1"^"1.7U1.4N D NXTNO(.DRN) Q:$D(DIERR) S DIBTPGM=DIBTPGM_$E("000",1,(4-$L(DRN)))_DRN
D NOW^%DTC,YX^%DTC
K ^UTILITY($J,0)
S ^UTILITY($J,0,1)=$P(DIBTPGM,U,2)_" ; GENERATED FROM '"_$P(^DIBT(DIBT1,0),U,1)_"' SORT TEMPLATE (#"_DIBT1_"), FILE:"_DP_", USER:"_$S($G(^VA(200,+DUZ,0))]"":$P(^(0),U),1:$P($G(^DIC(3,+DUZ,0)),U))_" ; "_Y
S ^UTILITY($J,0,2)=$T(DIOZ+1)
Q
;
NXTNO(DRN) ; GET NEXT AVAILABLE ROUTINE NUMBER
N DILOCK S DRN=0 D Q:DRN
N1 . S DILOCK=0,DRN=$O(^DI(.83,"C","n",DRN)) Q:'DRN D N3 G:DILOCK N1
N2 S DILOCK=0,DRN=$$NXTNO^DICLIB("^DI(.83,","","U") I DRN>9999 D BLD^DIALOG(1502) Q
D N3 G:DILOCK N2
Q
N3 L +^DI(.83,DRN,0):10 I '$T S DILOCK=1 Q
S ^DI(.83,DRN,0)=DRN_"^y",^DI(.83,"B",DRN,DRN)="",^DI(.83,"C","y",DRN)="" K ^DI(.83,"C","n",DRN) L -^DI(.83,DRN,0) Q
Q
;
ENRLS(DRN) ; MAKE ROUTINE NUMBER AVAILABLE FOR REUSE & DELETE ROUTINE
N DICLEAN,X S DRN=+$G(DRN),DICLEAN='DRN G:DRN R1
R S DRN=$O(^DI(.83,DRN)) Q:'DRN
R1 I $G(^DI(.83,DRN,0))]"" S $P(^(0),U,2)="n",^DI(.83,"C","n",DRN)="" K ^DI(.83,"C","y",DRN)
S X="DISZ"_$E("000",1,(4-$L(DRN)))_DRN X $G(^DD("OS",DISYS,"DEL"))
G:DICLEAN R
Q
;
QSV D:$G(DRN) ENRLS(DRN) K DIBTPGM
QER Q:$G(DIQUIET)
D MSG^DIALOG("W") S DIERR=1 Q
;
;DIALOG #101 'only those with programmer's access'
; #820 'no way to save routines on the system'
; #1501 'There is no code to save for this compiled...'
; #1502 'All available routine numbers...are in use...'
; #8028 '...currently compiled under namespace...'
; #8029 '...not currently compiled.'
; #8035 'Sort template'
; #9014 (help) 'if YES...Sort logic will be compiled...'
; #9019 (help) 'if YES...Sort logic...will NOT be compiled...'
;
TXT ;;
;;M X $S($D(DPQ):DX(DIXX),1:^UTILITY($J,99,DIXX))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIOZ 3785 printed Oct 16, 2024@18:53:07 Page 2
DIOZ ;SFISC/TKW - COMPILED SORT TEMPLATE ;30NOV2012
+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 ;
ENCU ;MARK A SORT TEMPLATE FOR ROUTINE COMPILATION
+1 IF $GET(DUZ(0))'="@"
WRITE !,$CHAR(7),$$EZBLD^DIALOG(101)
QUIT
EN1 NEW DDH,DIC,DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y,DIOZ
+1 ; NB: next 2 lines same in ENC. Need to make shared.
+2 if '$DATA(DISYS)
DO OS^DII
+3 IF $GET(^DD("OS",DISYS,"ZS"))=""
DO BLD^DIALOG(820)
GOTO QSV
+4 DO DIC
if Y<0
QUIT
SET DIOZ=+Y
+5 SET DIR(0)="Y"
+6 IF $GET(^DIBT(+Y,"ROU"))=""
Begin DoDot:1
+7 DO BLD^DIALOG(8029,$$EZBLD^DIALOG(8035),"","DIR(""A"")")
+8 SET DIR("B")="YES"
DO BLD^DIALOG(9014,"","","DIR(""?"")")
DO ^DIR
if 'Y
QUIT
+9 SET ^DIBT(DIOZ,"ROU")="^DISZ"
SET ^("ROUOLD")="DISZ"
+10 WRITE !!,$CHAR(7),DIR("?",2),!,DIR("?")
+11 QUIT
End DoDot:1
QUIT
+12 SET X(1)=$$EZBLD^DIALOG(8035)
SET X(2)="DISZ"
DO BLD^DIALOG(8028,.X,"","DIR(""A"")")
+13 SET DIR("B")="NO"
DO BLD^DIALOG(9019,"","","DIR(""?"")")
DO ^DIR
if 'Y
QUIT
+14 KILL ^DIBT(DIOZ,"ROU")
+15 WRITE !!,$CHAR(7),DIR("?",2),!,DIR("?")
+16 QUIT
+17 ;
DIC SET DIC="^DIBT("
SET DIC(0)="AEIQ"
SET DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,""Compiled"""
+1 SET DIC("S")="I '$P(^(0),U,8),Y'<1,$O(^DIBT(+Y,2,0))"
+2 DO ^DIC
QUIT
+3 ;
ENC ;CREATE COMPILED SORT ROUTINE
+1 ; NB: next 2 lines same in EN. Need to make shared.
+2 if '$DATA(DISYS)
DO OS^DII
+3 IF $GET(^DD("OS",DISYS,"ZS"))=""
DO BLD^DIALOG(820)
GOTO QSV
+4 IF $ORDER(^TMP("DIBTC",$JOB,""))=""
DO BLD^DIALOG(1501)
GOTO QSV
+5 NEW %,%H,%I,DIROUT,DIRUT,DTOUT,DUOUT,DRN,I,J,K,X,Y,DIR
+6 DO NEW
if $DATA(DIERR)
GOTO QSV
+7 SET K=2
SET I=""
FOR
SET I=$ORDER(^TMP("DIBTC",$JOB,I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^TMP("DIBTC",$JOB,I,J))
if 'J
QUIT
SET X=^(J)
IF X]""
SET K=K+1
SET ^UTILITY($JOB,0,K)=X
+8 FOR I=1:1
SET X=$PIECE($TEXT(TXT+I),";",3)
if X=""
QUIT
SET K=K+1
SET ^UTILITY($JOB,0,K)=X
+9 SET X=$PIECE(DIBTPGM,U,2)
XECUTE ^DD("OS",DISYS,"ZS")
+10 KILL ^TMP("DIBTC",$JOB)
+11 QUIT
+12 ;
NEW IF DIBTPGM'?1"^"1.7U1.4N
DO NXTNO(.DRN)
if $DATA(DIERR)
QUIT
SET DIBTPGM=DIBTPGM_$EXTRACT("000",1,(4-$LENGTH(DRN)))_DRN
+1 DO NOW^%DTC
DO YX^%DTC
+2 KILL ^UTILITY($JOB,0)
+3 SET ^UTILITY($JOB,0,1)=$PIECE(DIBTPGM,U,2)_" ; GENERATED FROM '"_$PIECE(^DIBT(DIBT1,0),U,1)_"' SORT TEMPLATE (#"_DIBT1_"), FILE:"_DP_", USER:"_$SELECT($GET(^VA(200,+DUZ,0))]"":$PIECE(^(0),U),1:$PIECE($GET(^DIC(3,+DUZ,0)),U))_" ; "_Y
+4 SET ^UTILITY($JOB,0,2)=$TEXT(DIOZ+1)
+5 QUIT
+6 ;
NXTNO(DRN) ; GET NEXT AVAILABLE ROUTINE NUMBER
+1 NEW DILOCK
SET DRN=0
Begin DoDot:1
N1 SET DILOCK=0
SET DRN=$ORDER(^DI(.83,"C","n",DRN))
if 'DRN
QUIT
DO N3
if DILOCK
GOTO N1
End DoDot:1
if DRN
QUIT
N2 SET DILOCK=0
SET DRN=$$NXTNO^DICLIB("^DI(.83,","","U")
IF DRN>9999
DO BLD^DIALOG(1502)
QUIT
+1 DO N3
if DILOCK
GOTO N2
+2 QUIT
N3 LOCK +^DI(.83,DRN,0):10
IF '$TEST
SET DILOCK=1
QUIT
+1 SET ^DI(.83,DRN,0)=DRN_"^y"
SET ^DI(.83,"B",DRN,DRN)=""
SET ^DI(.83,"C","y",DRN)=""
KILL ^DI(.83,"C","n",DRN)
LOCK -^DI(.83,DRN,0)
QUIT
+2 QUIT
+3 ;
ENRLS(DRN) ; MAKE ROUTINE NUMBER AVAILABLE FOR REUSE & DELETE ROUTINE
+1 NEW DICLEAN,X
SET DRN=+$GET(DRN)
SET DICLEAN='DRN
if DRN
GOTO R1
R SET DRN=$ORDER(^DI(.83,DRN))
if 'DRN
QUIT
R1 IF $GET(^DI(.83,DRN,0))]""
SET $PIECE(^(0),U,2)="n"
SET ^DI(.83,"C","n",DRN)=""
KILL ^DI(.83,"C","y",DRN)
+1 SET X="DISZ"_$EXTRACT("000",1,(4-$LENGTH(DRN)))_DRN
XECUTE $GET(^DD("OS",DISYS,"DEL"))
+2 if DICLEAN
GOTO R
+3 QUIT
+4 ;
QSV if $GET(DRN)
DO ENRLS(DRN)
KILL DIBTPGM
QER if $GET(DIQUIET)
QUIT
+1 DO MSG^DIALOG("W")
SET DIERR=1
QUIT
+2 ;
+3 ;DIALOG #101 'only those with programmer's access'
+4 ; #820 'no way to save routines on the system'
+5 ; #1501 'There is no code to save for this compiled...'
+6 ; #1502 'All available routine numbers...are in use...'
+7 ; #8028 '...currently compiled under namespace...'
+8 ; #8029 '...not currently compiled.'
+9 ; #8035 'Sort template'
+10 ; #9014 (help) 'if YES...Sort logic will be compiled...'
+11 ; #9019 (help) 'if YES...Sort logic...will NOT be compiled...'
+12 ;
TXT ;;
+1 ;;M X $S($D(DPQ):DX(DIXX),1:^UTILITY($J,99,DIXX))
