- 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 Feb 19, 2025@00:18:49 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))