source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKCBLD.m@ 1607

DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ;11:30 AM  9 Jul 2002
 ;;22.0;VA FileMan;**95**;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
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
 . X ^%ZOSF("TEST") E  Q
 . 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)