- DIFROM ;SFISC/XAK-GENERATE INITS ;03DEC2012
- ;;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.
- ;
- D Q
- S X=$S('$D(^DD("VERSION"))#2:0,1:^("VERSION")),Y=$P($T(DIFROM+1),";",3) G:X'=Y ERV K X,Y
- I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
- D WARN
- S DIR("A")="Enter the Name of the Package (2-4 characters)"
- S DIR(0)="FO^2:4:0^I X'?1U1.NU K X"
- S DIR("?")="^D R^DIFROMH",DIR("??")=DIR("?")
- D ^DIR G Q:$D(DIRUT) K DIR
- S DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC K D,DIC S DPK=+Y,DPK(0)=$S($D(Y(0)):Y(0),1:"")
- R W !!,"I am going to create a routine called '",X,"INIT'."
- S DTL=X,X=X_"INIT" D OS^DII
- I $D(^DD("OS",DISYS,18)) X ^(18) I W $C(7),!,"but '"_X_"' is ALREADY ON FILE!" S Q=1
- K DIR S DIR("A")="Is that OK",DIR(0)="Y",DIR("??")="^D R1^DIFROMH"
- D ^DIR G Q:$D(DIRUT)!'Y
- S DIR("A")="Would you like to include Data Dictionaries",DIR("B")="YES"
- S DIR("??")="^D R3^DIFROMH" D ^DIR G Q:$D(DIRUT) I 'Y S F(-1)=0 G DD
- G L:DPK<0 S DIR("A")="Would you like to see the package definition"
- S DIR("??")="^D CUR^DIFROMH1",DIR("B")="NO" D ^DIR G Q:$D(DIRUT)
- I Y D L^DIFROMH1
- S DIR("A")="Do you want to accept the current definition"
- S DIR(0)="Y",DIR("??")="^D PKG^DIFROMH1" D ^DIR G Q:$D(DIRUT) S DIH=Y
- F DA=0:0 S DA=$O(^DIC(9.4,DPK,4,DA)) G:'$D(^(+DA,0)) DD:$D(F),L S Y=+^(0) I $D(^DIC(Y,0))#2 S F(Y)=$P(^(0),U) W !!,F(Y) D SF G Q:%<0
- L W !!,"THEN PLEASE LIST THE FILES THAT YOU WISH TO TRANSPORT:" S DIH=0,DPK=-1
- F F=1:1 G Q:$D(DTOUT) K DIC S DIC("S")="I Y>1.9999&'$D(F(+Y))",DIC(0)="AIQEZ",DIC="^DIC(" D ^DIC G:Y<0 Q:X[U,DD S F(+Y)=$P(Y,U,2) D F
- DD W ! F Y=1,2,3,4 S D=$P("DIE^DIPT^DIBT^DIST",U,Y),DIC=$P("INPUT^PRINT^SORT^FORM(S):",U,Y)_$S(Y<4:" TEMPLATE(S):",1:"") F %=0:0 S %=$O(^DIC(9.4,DPK,D,%)) Q:'$D(^(+%,0)) S DH=$P(^(0),U),X=$P(^(0),U,2) D T
- S DN=DTL_$E("INI",1,5-$L(DTL))
- K ^UTILITY(U,$J),DR S DRN=0,F=0,Q=DPK G Q:$D(F)+$D(Q)=2
- D VER^DIFROM12 G Q:$D(DIRUT)
- S G ^DIFROM0
- ;
- T W !,DIC,?24,DH
- I Y'=4 F F=0:0 S @("F=$O(^"_D_"(""B"",DH,F))"),DIC="" Q:'F I @("$D(^"_D_"(F,0))"),$P(^(0),U,4)=X!'X S Q(D,F)="",DIFC=1 G TQ
- I Y=4 F F=0:0 S F=$O(^DIST(.403,"B",DH,F)),DIC="" Q:'F I $D(^DIST(.403,F,0)),$P(^(0),U,8)=X S Q(D,F)="",DIFC=1 G TQ
- W $C(7)," **NOT FOUND** "
- TQ Q
- ;
- SF G F:$O(^DIC(9.4,DPK,4,DA,1,0))'>0
- F %=0:0 S %=$O(^DIC(9.4,DPK,4,DA,1,%)) Q:%'>0 I $D(^(%,0)) S E=$P(^(0),U),D=$O(^DD(+Y,"B",E,0)) D:D="" ERF I $D(^DD(+Y,D,0)) S F(+Y,+Y,D)="",%C=+$P(^(0),U,2) I %C W " (",E,")" S F(+Y,%C)=0
- S F(+Y,+Y)=1,E=+Y S:(+Y'=200)!(DTL="XU") F(+Y,+Y,.01)=0 G E
- F S F(+Y,+Y)=0,%=1,E=0 K %A
- ; VEN/SMH 3121029 - Change below to that S F(+Y,D)=0 not "", to conform with KIDS FIA format.
- ; IX & KEYS on subfiles don't get exported with KIDS otherwise. For V22.2.
- E F E=E:0 S E=$O(F(+Y,E)) Q:E'>0 F D=0:0 S D=$O(^DD(E,"SB",D)) Q:D'>0 I Y-E!'$D(%A)!$D(%A(D)) S F(+Y,D)=0 S:$D(%A) %A(D)=0
- S F(+Y,0)=^DIC(+Y,0,"GL"),D=$P(@(F(+Y,0)_"0)"),U,4),DPK(1)=+Y S:D<2 D=""
- S DA(1)=DPK,DR="222.1;222.2;223;222.4;222.7;S:""n""[X Y=0;222.8;222.9;"
- S DIE=$S(DPK>0:"^DIC(9.4,",1:"^UTILITY($J,")_DA(1)_",4,"
- I DPK<0 S ^UTILITY($J,-1,4,0)="^9.44",^(+Y,0)=+Y,DA=+Y
- I 'DIH W ! S DIE("W")="W !?2,$P(DQ(DQ),U),?32,"": """ D ^DIE I $D(Y) S %=-1
- S F(DPK(1),-222)=$S($D(@(DIE_"DA,222)")):^(222),1:"y"),F(DPK(1),-223)=$S($D(^(223)):^(223),1:"") K DIE,DR
- Q
- ;
- ERF S D=-1 W $C(7),!," INVALID FIELD LABEL: "_E,! Q
- ERV W $C(7),!!,"Your FileMan Version number: "_X_" does not match the version number",!,"on the DIFROM routine: "_Y_" !!",!!,"You must run ^DINIT before you can build an INIT!!",! K X,Y Q
- Q G Q^DIFROM11
- WARN N I F I=1:1 Q:$T(WARN+I)="" W !,$P($T(WARN+I),";;",2)
- ;; * * Please Note * *
- ;;
- ;; DIFROM generates routines in the following format:
- ;;
- ;; nmspInxx
- ;; ^^^^^^^^
- ;; ||||||||
- ;; |||||| \\- xx is any combination of numbers and
- ;; |||||| uppercase alpha characters.
- ;; ||||||
- ;; ||||| \--- n is a number 0 - 9 and uppercase letter N.
- ;; |||||
- ;; |||| \---- I is always uppercase letter I.
- ;; ||||
- ;; \\\\----- 2 to 4 characters of package namespace.
- ;;
- ;; Any routines that support the init process should not
- ;; be in this format.
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROM 4513 printed Jan 18, 2025@03:48:56 Page 2
- DIFROM ;SFISC/XAK-GENERATE INITS ;03DEC2012
- +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 DO Q
- +8 SET X=$SELECT('$DATA(^DD("VERSION"))#2:0,1:^("VERSION"))
- SET Y=$PIECE($TEXT(DIFROM+1),";",3)
- if X'=Y
- GOTO ERV
- KILL X,Y
- +9 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)'="@":1,1:0)
- WRITE !,"PROGRAMMER ACCESS REQUIRED",!
- QUIT
- +10 DO WARN
- +11 SET DIR("A")="Enter the Name of the Package (2-4 characters)"
- +12 SET DIR(0)="FO^2:4:0^I X'?1U1.NU K X"
- +13 SET DIR("?")="^D R^DIFROMH"
- SET DIR("??")=DIR("?")
- +14 DO ^DIR
- if $DATA(DIRUT)
- GOTO Q
- KILL DIR
- +15 SET DIC="^DIC(9.4,"
- SET DIC(0)="EZ"
- SET D="C"
- DO IX^DIC
- KILL D,DIC
- SET DPK=+Y
- SET DPK(0)=$SELECT($DATA(Y(0)):Y(0),1:"")
- R WRITE !!,"I am going to create a routine called '",X,"INIT'."
- +1 SET DTL=X
- SET X=X_"INIT"
- DO OS^DII
- +2 IF $DATA(^DD("OS",DISYS,18))
- XECUTE ^(18)
- IF $TEST
- WRITE $CHAR(7),!,"but '"_X_"' is ALREADY ON FILE!"
- SET Q=1
- +3 KILL DIR
- SET DIR("A")="Is that OK"
- SET DIR(0)="Y"
- SET DIR("??")="^D R1^DIFROMH"
- +4 DO ^DIR
- if $DATA(DIRUT)!'Y
- GOTO Q
- +5 SET DIR("A")="Would you like to include Data Dictionaries"
- SET DIR("B")="YES"
- +6 SET DIR("??")="^D R3^DIFROMH"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO Q
- IF 'Y
- SET F(-1)=0
- GOTO DD
- +7 if DPK<0
- GOTO L
- SET DIR("A")="Would you like to see the package definition"
- +8 SET DIR("??")="^D CUR^DIFROMH1"
- SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO Q
- +9 IF Y
- DO L^DIFROMH1
- +10 SET DIR("A")="Do you want to accept the current definition"
- +11 SET DIR(0)="Y"
- SET DIR("??")="^D PKG^DIFROMH1"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO Q
- SET DIH=Y
- +12 FOR DA=0:0
- SET DA=$ORDER(^DIC(9.4,DPK,4,DA))
- if '$DATA(^(+DA,0))
- if $DATA(F)
- GOTO DD
- GOTO L
- SET Y=+^(0)
- IF $DATA(^DIC(Y,0))#2
- SET F(Y)=$PIECE(^(0),U)
- WRITE !!,F(Y)
- DO SF
- if %<0
- GOTO Q
- L WRITE !!,"THEN PLEASE LIST THE FILES THAT YOU WISH TO TRANSPORT:"
- SET DIH=0
- SET DPK=-1
- +1 FOR F=1:1
- if $DATA(DTOUT)
- GOTO Q
- KILL DIC
- SET DIC("S")="I Y>1.9999&'$D(F(+Y))"
- SET DIC(0)="AIQEZ"
- SET DIC="^DIC("
- DO ^DIC
- if Y<0
- if X[U
- GOTO Q
- GOTO DD
- SET F(+Y)=$PIECE(Y,U,2)
- DO F
- DD WRITE !
- FOR Y=1,2,3,4
- SET D=$PIECE("DIE^DIPT^DIBT^DIST",U,Y)
- SET DIC=$PIECE("INPUT^PRINT^SORT^FORM(S):",U,Y)_$SELECT(Y<4:" TEMPLATE(S):",1:"")
- FOR %=0:0
- SET %=$ORDER(^DIC(9.4,DPK,D,%))
- if '$DATA(^(+%,0))
- QUIT
- SET DH=$PIECE(^(0),U)
- SET X=$PIECE(^(0),U,2)
- DO T
- +1 SET DN=DTL_$EXTRACT("INI",1,5-$LENGTH(DTL))
- +2 KILL ^UTILITY(U,$JOB),DR
- SET DRN=0
- SET F=0
- SET Q=DPK
- if $DATA(F)+$DATA(Q)=2
- GOTO Q
- +3 DO VER^DIFROM12
- if $DATA(DIRUT)
- GOTO Q
- S GOTO ^DIFROM0
- +1 ;
- T WRITE !,DIC,?24,DH
- +1 IF Y'=4
- FOR F=0:0
- SET @("F=$O(^"_D_"(""B"",DH,F))")
- SET DIC=""
- if 'F
- QUIT
- IF @("$D(^"_D_"(F,0))")
- IF $PIECE(^(0),U,4)=X!'X
- SET Q(D,F)=""
- SET DIFC=1
- GOTO TQ
- +2 IF Y=4
- FOR F=0:0
- SET F=$ORDER(^DIST(.403,"B",DH,F))
- SET DIC=""
- if 'F
- QUIT
- IF $DATA(^DIST(.403,F,0))
- IF $PIECE(^(0),U,8)=X
- SET Q(D,F)=""
- SET DIFC=1
- GOTO TQ
- +3 WRITE $CHAR(7)," **NOT FOUND** "
- TQ QUIT
- +1 ;
- SF if $ORDER(^DIC(9.4,DPK,4,DA,1,0))'>0
- GOTO F
- +1 FOR %=0:0
- SET %=$ORDER(^DIC(9.4,DPK,4,DA,1,%))
- if %'>0
- QUIT
- IF $DATA(^(%,0))
- SET E=$PIECE(^(0),U)
- SET D=$ORDER(^DD(+Y,"B",E,0))
- if D=""
- DO ERF
- IF $DATA(^DD(+Y,D,0))
- SET F(+Y,+Y,D)=""
- SET %C=+$PIECE(^(0),U,2)
- IF %C
- WRITE " (",E,")"
- SET F(+Y,%C)=0
- +2 SET F(+Y,+Y)=1
- SET E=+Y
- if (+Y'=200)!(DTL="XU")
- SET F(+Y,+Y,.01)=0
- GOTO E
- F SET F(+Y,+Y)=0
- SET %=1
- SET E=0
- KILL %A
- +1 ; VEN/SMH 3121029 - Change below to that S F(+Y,D)=0 not "", to conform with KIDS FIA format.
- +2 ; IX & KEYS on subfiles don't get exported with KIDS otherwise. For V22.2.
- E FOR E=E:0
- SET E=$ORDER(F(+Y,E))
- if E'>0
- QUIT
- FOR D=0:0
- SET D=$ORDER(^DD(E,"SB",D))
- if D'>0
- QUIT
- IF Y-E!'$DATA(%A)!$DATA(%A(D))
- SET F(+Y,D)=0
- if $DATA(%A)
- SET %A(D)=0
- +1 SET F(+Y,0)=^DIC(+Y,0,"GL")
- SET D=$PIECE(@(F(+Y,0)_"0)"),U,4)
- SET DPK(1)=+Y
- if D<2
- SET D=""
- +2 SET DA(1)=DPK
- SET DR="222.1;222.2;223;222.4;222.7;S:""n""[X Y=0;222.8;222.9;"
- +3 SET DIE=$SELECT(DPK>0:"^DIC(9.4,",1:"^UTILITY($J,")_DA(1)_",4,"
- +4 IF DPK<0
- SET ^UTILITY($JOB,-1,4,0)="^9.44"
- SET ^(+Y,0)=+Y
- SET DA=+Y
- +5 IF 'DIH
- WRITE !
- SET DIE("W")="W !?2,$P(DQ(DQ),U),?32,"": """
- DO ^DIE
- IF $DATA(Y)
- SET %=-1
- +6 SET F(DPK(1),-222)=$SELECT($DATA(@(DIE_"DA,222)")):^(222),1:"y")
- SET F(DPK(1),-223)=$SELECT($DATA(^(223)):^(223),1:"")
- KILL DIE,DR
- +7 QUIT
- +8 ;
- ERF SET D=-1
- WRITE $CHAR(7),!," INVALID FIELD LABEL: "_E,!
- QUIT
- ERV WRITE $CHAR(7),!!,"Your FileMan Version number: "_X_" does not match the version number",!,"on the DIFROM routine: "_Y_" !!",!!,"You must run ^DINIT before you can build an INIT!!",!
- KILL X,Y
- QUIT
- Q GOTO Q^DIFROM11
- WARN NEW I
- FOR I=1:1
- if $TEXT(WARN+I)=""
- QUIT
- WRITE !,$PIECE($TEXT(WARN+I),";;",2)
- +1 ;; * * Please Note * *
- +2 ;;
- +3 ;; DIFROM generates routines in the following format:
- +4 ;;
- +5 ;; nmspInxx
- +6 ;; ^^^^^^^^
- +7 ;; ||||||||
- +8 ;; |||||| \\- xx is any combination of numbers and
- +9 ;; |||||| uppercase alpha characters.
- +10 ;; ||||||
- +11 ;; ||||| \--- n is a number 0 - 9 and uppercase letter N.
- +12 ;; |||||
- +13 ;; |||| \---- I is always uppercase letter I.
- +14 ;; ||||
- +15 ;; \\\\----- 2 to 4 characters of package namespace.
- +16 ;;
- +17 ;; Any routines that support the init process should not
- +18 ;; be in this format.
- +19 ;;