DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ;15NOV2012
;;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.
;
MAIN ;Main process
N DIKCRTN,DIKCNMSP,DIKCITL,DIKCXR,%
;
;Check save code
D:'$D(DISYS) OS^DII
I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
;
;Gather information from user
Q1 S DIKCRTN=$$ASKRTN Q:U[DIKCRTN
Q2 S DIKCITL=$$ASKITL Q:DIKCITL[U I DIKCITL="" W ! G Q1
Q3 S DIKCNMSP=$$ASKNMSP Q:DIKCNMSP[U I DIKCNMSP="" W ! G Q2
Q4 S DIKCXR=$$ASKXR() I 'DIKCXR W ! G Q3
;
;Build and save routine
D BUILD(DIKCRTN,DIKCITL,DIKCNMSP,DIKCXR)
D SAVE(DIKCRTN)
;
;Final message and clean up
W !!," Done!"
W !!," Be sure to edit the routine to fill in the missing details,"
W !," and to customize the call to CREIXN^DDMOD."
W !
K ^UTILITY($J)
Q
;
BUILD(DIKCRTN,DIKCITL,NS,XR) ;Build routine DIKCRTN
N CV
K ^UTILITY($J)
D AD(DIKCRTN_" ;xxxx/"_DIKCITL_"-CREATE NEW-STYLE XREF ;")
D AD(" ;;1.0")
D AD(" ;")
D AD(" N "_NS_"XR,"_NS_"RES,"_NS_"OUT")
D BC(NS,XR,"FILE",0,1)
D:$P($G(^DD("IX",XR,0)),U,8)="W" BC(NS,XR,"ROOT FILE",0,9)
D BC(NS,XR,"NAME",0,2)
D BC(NS,XR,"TYPE",0,4)
D BC(NS,XR,"USE",0,14)
D BC(NS,XR,"EXECUTION",0,6)
D BC(NS,XR,"ACTIVITY",0,7)
D BC(NS,XR,"SHORT DESCR",0,3)
D BCW(NS,XR,"DESCR",.1)
D:$P($G(^DD("IX",XR,0)),U,4)="MU"
. D BC(NS,XR,"SET",1)
. D BC(NS,XR,"KILL",2)
. D BC(NS,XR,"WHOLE KILL",2.5)
D BC(NS,XR,"SET CONDITION",1.4)
D BC(NS,XR,"KILL CONDITION",2.4)
;
S CV=0 F S CV=$O(^DD("IX",XR,11.1,CV)) Q:'CV D
. N ON,TP,VAL
. S ON=$P($G(^DD("IX",XR,11.1,CV,0)),U) Q:'ON
. S TP=$P($G(^DD("IX",XR,11.1,CV,0)),U,2)
. I TP="F" D
.. S VAL=$P($G(^DD("IX",XR,11.1,CV,0)),U,4) Q:'VAL
.. D AD(" S "_NS_"XR(""VAL"","_ON_")="_VAL)
. E D
.. S VAL=$G(^DD("IX",XR,11.1,CV,1.5)) Q:VAL=""
.. D AD(" S "_NS_"XR(""VAL"","_ON_")="_$$QT(VAL))
. D BCC(NS,XR,CV,ON,"SUBSCRIPT",0,6)
. D BCC(NS,XR,CV,ON,"LENGTH",0,5)
. D BCC(NS,XR,CV,ON,"COLLATION",0,7)
. D BCC(NS,XR,CV,ON,"LOOKUP PROMPT",0,8)
. D:TP="F"
.. D BCC(NS,XR,CV,ON,"XFORM FOR STORAGE",2)
.. D BCC(NS,XR,CV,ON,"XFORM FOR LOOKUP",4)
.. D BCC(NS,XR,CV,ON,"XFORM FOR DISPLAY",3)
;
D AD(" D CREIXN^DDMOD(."_NS_"XR,""SW"",."_NS_"RES,"""_NS_"OUT"")")
D AD(" Q")
;
Q
BC(NS,XR,SUB,ND,PC) ;Build code that sets an array element
N VAL
I $G(PC)="" S VAL=$G(^DD("IX",XR,ND))
E S VAL=$P($G(^DD("IX",XR,ND)),U,PC)
Q:VAL=""
D AD(" S "_NS_"XR("""_SUB_""")="_$$QT(VAL))
Q
;
BCW(NS,XR,SUB,ND) ;Build code that sets array for wp field
N I,VAL
S I=0 F S I=$O(^DD("IX",XR,ND,I)) Q:'I D
. S VAL=$G(^DD("IX",XR,ND,I,0)) S:VAL="" VAL=" "
. D AD(" S "_NS_"XR("""_SUB_""","_I_")="_$$QT(VAL))
Q
;
BCC(NS,XR,CV,ON,SUB,ND,PC) ;Build code that sets an array element
N VAL
I $G(PC)="" S VAL=$G(^DD("IX",XR,11.1,CV,ND))
E S VAL=$P($G(^DD("IX",XR,11.1,CV,ND)),U,PC)
Q:VAL=""
D AD(" S "_NS_"XR(""VAL"","_ON_","""_SUB_""")="_$$QT(VAL))
Q
;
QT(X) ;Return string X quoted, if noncanonic
Q:$G(X)="" """"""
Q:X=+$E($P(X,"E"),1,15) X
S X(X)="",X=$Q(X(""))
Q $E(X,3,$L(X)-1)
;
AD(X) ;Add a routine line to ^UTILITY
N LN
S LN=$O(^UTILITY($J,0," "),-1)+1
S ^UTILITY($J,0,LN)=X
Q
;
SAVE(DIKCRTN) ;Save routine DIKCRTN
N X,%Y
S ^UTILITY($J,0,1)=^UTILITY($J,0,1)_$$NOW
S X=DIKCRTN X ^DD("OS",DISYS,"ZS")
W !!,$$EZBLD^DIALOG(8025,DIKCRTN)
Q
;
ASKRTN() ;Prompt for routine name; return ^ if timeout, null, or ^
N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="FO^1:8^K:X?.E1.C.E!'(X?1""%""1.7AN!(X?1A1.7AN)) X"
S DIR("A")="Routine name"
S DIR("?",1)=" Enter the name of the routine, without the leading up-arrow, that"
S DIR("?",2)=" should be built."
S DIR("?",3)=""
S DIR("?",4)=" Answer must be 1-8 characters in length. It must begin with % or a"
S DIR("?")=" letter, followed by a combination of letters and numbers."
F D Q:$G(DIKCRTN)]""
. D ^DIR I $D(DIRUT) S DIKCRTN=U Q
. S DIKCRTN=X
. Q:$T(^@X)="" ; routine doesn't exist; overwrite okay. VEN/SMH
. Q:$$ASKREPL(DIKCRTN)
. S DIKCRTN=""
Q $G(DIKCRTN)
;
ASKREPL(DIKCRTN) ;Ask whether to replace the existing routine
N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YO"
S DIR("A")=" Do you wish to replace routine "_DIKCRTN
S DIR("B")="NO"
S DIR("?")=" Answer yes if you wish to replace routine "_DIKCRTN_" with a new version."
W !!," Routine "_DIKCRTN_" already exists."
D ^DIR W !
Q Y
;
ASKITL() ;Ask for programmer initials
N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="FO^1:15"
S DIR("A")="Programmer initials"
S DIR("?",1)=" Enter your initials, which will appear on the first line of the"
S DIR("?")=" routine."
D ^DIR
Q Y
;
ASKNMSP() ;Prompt for a namespace
N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="FO^1:4^K:X?.E1.C.E!'(X?1""%""1.3AN!(X?1A1.3AN)) X"
S DIR("A")="Namespace to use for local variables"
S DIR("?",1)=" All variables used in the generated routine will start with the namespace"
S DIR("?",2)=" you choose."
S DIR("?",3)=""
S DIR("?",4)=" Answer must be 1-4 characters in length. It must begin with % or a"
S DIR("?")=" letter, followed by a combination of letters and numbers."
D ^DIR
Q Y
;
ASKXR() ;Prompt for file/xref
N DIKCCNT,DIKCROOT,DIKCTOP,DIKCFILE,DDS1,D,DIC,X,Y
S DDS1="CROSS-REFERENCE FROM: " D W^DICRW Q:Y<0 ""
S DIKCTOP=+$P($G(@(DIC_"0)")),U,2) Q:'DIKCTOP ""
S DIKCFILE=$$SUB^DIKCU(DIKCTOP)
;
D GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
W ! D LIST^DIKCUTL2(.DIKCCNT)
Q $$CHOOSE^DIKCUTL2(.DIKCCNT,"to build a routine for")
;
NOW() ;Return current time in external form
N %,%I,%H,AP,HR,MIN,MON,TIM,X
D NOW^%DTC
S TIM=$P(%,".",2)
S HR=$E(TIM,1,2)
S AP=$S(HR<12:"AM",1:"PM")
S HR=$S(HR<13:+HR,1:HR#12)
S MIN=$E(TIM_"0000",3,4)
;
S MON=$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,%I(1))
Q HR_":"_MIN_" "_AP_" "_%I(2)_" "_MON_" "_(%I(3)+1700)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCBLD 6188 printed Dec 13, 2024@02:48:43 Page 2
DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ;15NOV2012
+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 ;
MAIN ;Main process
+1 NEW DIKCRTN,DIKCNMSP,DIKCITL,DIKCXR,%
+2 ;
+3 ;Check save code
+4 if '$DATA(DISYS)
DO OS^DII
+5 IF '$DATA(^DD("OS",DISYS,"ZS"))
WRITE $CHAR(7),$$EZBLD^DIALOG(820)
QUIT
+6 ;
+7 ;Gather information from user
Q1 SET DIKCRTN=$$ASKRTN
if U[DIKCRTN
QUIT
Q2 SET DIKCITL=$$ASKITL
if DIKCITL[U
QUIT
IF DIKCITL=""
WRITE !
GOTO Q1
Q3 SET DIKCNMSP=$$ASKNMSP
if DIKCNMSP[U
QUIT
IF DIKCNMSP=""
WRITE !
GOTO Q2
Q4 SET DIKCXR=$$ASKXR()
IF 'DIKCXR
WRITE !
GOTO Q3
+1 ;
+2 ;Build and save routine
+3 DO BUILD(DIKCRTN,DIKCITL,DIKCNMSP,DIKCXR)
+4 DO SAVE(DIKCRTN)
+5 ;
+6 ;Final message and clean up
+7 WRITE !!," Done!"
+8 WRITE !!," Be sure to edit the routine to fill in the missing details,"
+9 WRITE !," and to customize the call to CREIXN^DDMOD."
+10 WRITE !
+11 KILL ^UTILITY($JOB)
+12 QUIT
+13 ;
BUILD(DIKCRTN,DIKCITL,NS,XR) ;Build routine DIKCRTN
+1 NEW CV
+2 KILL ^UTILITY($JOB)
+3 DO AD(DIKCRTN_" ;xxxx/"_DIKCITL_"-CREATE NEW-STYLE XREF ;")
+4 DO AD(" ;;1.0")
+5 DO AD(" ;")
+6 DO AD(" N "_NS_"XR,"_NS_"RES,"_NS_"OUT")
+7 DO BC(NS,XR,"FILE",0,1)
+8 if $PIECE($GET(^DD("IX",XR,0)),U,8)="W"
DO BC(NS,XR,"ROOT FILE",0,9)
+9 DO BC(NS,XR,"NAME",0,2)
+10 DO BC(NS,XR,"TYPE",0,4)
+11 DO BC(NS,XR,"USE",0,14)
+12 DO BC(NS,XR,"EXECUTION",0,6)
+13 DO BC(NS,XR,"ACTIVITY",0,7)
+14 DO BC(NS,XR,"SHORT DESCR",0,3)
+15 DO BCW(NS,XR,"DESCR",.1)
+16 if $PIECE($GET(^DD("IX",XR,0)),U,4)="MU"
Begin DoDot:1
+17 DO BC(NS,XR,"SET",1)
+18 DO BC(NS,XR,"KILL",2)
+19 DO BC(NS,XR,"WHOLE KILL",2.5)
End DoDot:1
+20 DO BC(NS,XR,"SET CONDITION",1.4)
+21 DO BC(NS,XR,"KILL CONDITION",2.4)
+22 ;
+23 SET CV=0
FOR
SET CV=$ORDER(^DD("IX",XR,11.1,CV))
if 'CV
QUIT
Begin DoDot:1
+24 NEW ON,TP,VAL
+25 SET ON=$PIECE($GET(^DD("IX",XR,11.1,CV,0)),U)
if 'ON
QUIT
+26 SET TP=$PIECE($GET(^DD("IX",XR,11.1,CV,0)),U,2)
+27 IF TP="F"
Begin DoDot:2
+28 SET VAL=$PIECE($GET(^DD("IX",XR,11.1,CV,0)),U,4)
if 'VAL
QUIT
+29 DO AD(" S "_NS_"XR(""VAL"","_ON_")="_VAL)
End DoDot:2
+30 IF '$TEST
Begin DoDot:2
+31 SET VAL=$GET(^DD("IX",XR,11.1,CV,1.5))
if VAL=""
QUIT
+32 DO AD(" S "_NS_"XR(""VAL"","_ON_")="_$$QT(VAL))
End DoDot:2
+33 DO BCC(NS,XR,CV,ON,"SUBSCRIPT",0,6)
+34 DO BCC(NS,XR,CV,ON,"LENGTH",0,5)
+35 DO BCC(NS,XR,CV,ON,"COLLATION",0,7)
+36 DO BCC(NS,XR,CV,ON,"LOOKUP PROMPT",0,8)
+37 if TP="F"
Begin DoDot:2
+38 DO BCC(NS,XR,CV,ON,"XFORM FOR STORAGE",2)
+39 DO BCC(NS,XR,CV,ON,"XFORM FOR LOOKUP",4)
+40 DO BCC(NS,XR,CV,ON,"XFORM FOR DISPLAY",3)
End DoDot:2
End DoDot:1
+41 ;
+42 DO AD(" D CREIXN^DDMOD(."_NS_"XR,""SW"",."_NS_"RES,"""_NS_"OUT"")")
+43 DO AD(" Q")
+44 ;
+45 QUIT
BC(NS,XR,SUB,ND,PC) ;Build code that sets an array element
+1 NEW VAL
+2 IF $GET(PC)=""
SET VAL=$GET(^DD("IX",XR,ND))
+3 IF '$TEST
SET VAL=$PIECE($GET(^DD("IX",XR,ND)),U,PC)
+4 if VAL=""
QUIT
+5 DO AD(" S "_NS_"XR("""_SUB_""")="_$$QT(VAL))
+6 QUIT
+7 ;
BCW(NS,XR,SUB,ND) ;Build code that sets array for wp field
+1 NEW I,VAL
+2 SET I=0
FOR
SET I=$ORDER(^DD("IX",XR,ND,I))
if 'I
QUIT
Begin DoDot:1
+3 SET VAL=$GET(^DD("IX",XR,ND,I,0))
if VAL=""
SET VAL=" "
+4 DO AD(" S "_NS_"XR("""_SUB_""","_I_")="_$$QT(VAL))
End DoDot:1
+5 QUIT
+6 ;
BCC(NS,XR,CV,ON,SUB,ND,PC) ;Build code that sets an array element
+1 NEW VAL
+2 IF $GET(PC)=""
SET VAL=$GET(^DD("IX",XR,11.1,CV,ND))
+3 IF '$TEST
SET VAL=$PIECE($GET(^DD("IX",XR,11.1,CV,ND)),U,PC)
+4 if VAL=""
QUIT
+5 DO AD(" S "_NS_"XR(""VAL"","_ON_","""_SUB_""")="_$$QT(VAL))
+6 QUIT
+7 ;
QT(X) ;Return string X quoted, if noncanonic
+1 if $GET(X)=""
QUIT """"""
+2 if X=+$EXTRACT($PIECE(X,"E"),1,15)
QUIT X
+3 SET X(X)=""
SET X=$QUERY(X(""))
+4 QUIT $EXTRACT(X,3,$LENGTH(X)-1)
+5 ;
AD(X) ;Add a routine line to ^UTILITY
+1 NEW LN
+2 SET LN=$ORDER(^UTILITY($JOB,0," "),-1)+1
+3 SET ^UTILITY($JOB,0,LN)=X
+4 QUIT
+5 ;
SAVE(DIKCRTN) ;Save routine DIKCRTN
+1 NEW X,%Y
+2 SET ^UTILITY($JOB,0,1)=^UTILITY($JOB,0,1)_$$NOW
+3 SET X=DIKCRTN
XECUTE ^DD("OS",DISYS,"ZS")
+4 WRITE !!,$$EZBLD^DIALOG(8025,DIKCRTN)
+5 QUIT
+6 ;
ASKRTN() ;Prompt for routine name; return ^ if timeout, null, or ^
+1 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="FO^1:8^K:X?.E1.C.E!'(X?1""%""1.7AN!(X?1A1.7AN)) X"
+3 SET DIR("A")="Routine name"
+4 SET DIR("?",1)=" Enter the name of the routine, without the leading up-arrow, that"
+5 SET DIR("?",2)=" should be built."
+6 SET DIR("?",3)=""
+7 SET DIR("?",4)=" Answer must be 1-8 characters in length. It must begin with % or a"
+8 SET DIR("?")=" letter, followed by a combination of letters and numbers."
+9 FOR
Begin DoDot:1
+10 DO ^DIR
IF $DATA(DIRUT)
SET DIKCRTN=U
QUIT
+11 SET DIKCRTN=X
+12 ; routine doesn't exist; overwrite okay. VEN/SMH
if $TEXT(^@X)=""
QUIT
+13 if $$ASKREPL(DIKCRTN)
QUIT
+14 SET DIKCRTN=""
End DoDot:1
if $GET(DIKCRTN)]""
QUIT
+15 QUIT $GET(DIKCRTN)
+16 ;
ASKREPL(DIKCRTN) ;Ask whether to replace the existing routine
+1 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="YO"
+3 SET DIR("A")=" Do you wish to replace routine "_DIKCRTN
+4 SET DIR("B")="NO"
+5 SET DIR("?")=" Answer yes if you wish to replace routine "_DIKCRTN_" with a new version."
+6 WRITE !!," Routine "_DIKCRTN_" already exists."
+7 DO ^DIR
WRITE !
+8 QUIT Y
+9 ;
ASKITL() ;Ask for programmer initials
+1 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="FO^1:15"
+3 SET DIR("A")="Programmer initials"
+4 SET DIR("?",1)=" Enter your initials, which will appear on the first line of the"
+5 SET DIR("?")=" routine."
+6 DO ^DIR
+7 QUIT Y
+8 ;
ASKNMSP() ;Prompt for a namespace
+1 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="FO^1:4^K:X?.E1.C.E!'(X?1""%""1.3AN!(X?1A1.3AN)) X"
+3 SET DIR("A")="Namespace to use for local variables"
+4 SET DIR("?",1)=" All variables used in the generated routine will start with the namespace"
+5 SET DIR("?",2)=" you choose."
+6 SET DIR("?",3)=""
+7 SET DIR("?",4)=" Answer must be 1-4 characters in length. It must begin with % or a"
+8 SET DIR("?")=" letter, followed by a combination of letters and numbers."
+9 DO ^DIR
+10 QUIT Y
+11 ;
ASKXR() ;Prompt for file/xref
+1 NEW DIKCCNT,DIKCROOT,DIKCTOP,DIKCFILE,DDS1,D,DIC,X,Y
+2 SET DDS1="CROSS-REFERENCE FROM: "
DO W^DICRW
if Y<0
QUIT ""
+3 SET DIKCTOP=+$PIECE($GET(@(DIC_"0)")),U,2)
if 'DIKCTOP
QUIT ""
+4 SET DIKCFILE=$$SUB^DIKCU(DIKCTOP)
+5 ;
+6 DO GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
+7 WRITE !
DO LIST^DIKCUTL2(.DIKCCNT)
+8 QUIT $$CHOOSE^DIKCUTL2(.DIKCCNT,"to build a routine for")
+9 ;
NOW() ;Return current time in external form
+1 NEW %,%I,%H,AP,HR,MIN,MON,TIM,X
+2 DO NOW^%DTC
+3 SET TIM=$PIECE(%,".",2)
+4 SET HR=$EXTRACT(TIM,1,2)
+5 SET AP=$SELECT(HR<12:"AM",1:"PM")
+6 SET HR=$SELECT(HR<13:+HR,1:HR#12)
+7 SET MIN=$EXTRACT(TIM_"0000",3,4)
+8 ;
+9 SET MON=$PIECE("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,%I(1))
+10 QUIT HR_":"_MIN_" "_AP_" "_%I(2)_" "_MON_" "_(%I(3)+1700)
