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 Apr 09, 2024@21:53:47 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 ;;
