Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIKCBLD

DIKCBLD.m

Go to the documentation of this file.
  1. DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ;15NOV2012
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. MAIN ;Main process
  1. N DIKCRTN,DIKCNMSP,DIKCITL,DIKCXR,%
  1. ;
  1. ;Check save code
  1. D:'$D(DISYS) OS^DII
  1. I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
  1. ;
  1. ;Gather information from user
  1. Q1 S DIKCRTN=$$ASKRTN Q:U[DIKCRTN
  1. Q2 S DIKCITL=$$ASKITL Q:DIKCITL[U I DIKCITL="" W ! G Q1
  1. Q3 S DIKCNMSP=$$ASKNMSP Q:DIKCNMSP[U I DIKCNMSP="" W ! G Q2
  1. Q4 S DIKCXR=$$ASKXR() I 'DIKCXR W ! G Q3
  1. ;
  1. ;Build and save routine
  1. D BUILD(DIKCRTN,DIKCITL,DIKCNMSP,DIKCXR)
  1. D SAVE(DIKCRTN)
  1. ;
  1. ;Final message and clean up
  1. W !!," Done!"
  1. W !!," Be sure to edit the routine to fill in the missing details,"
  1. W !," and to customize the call to CREIXN^DDMOD."
  1. W !
  1. K ^UTILITY($J)
  1. Q
  1. ;
  1. BUILD(DIKCRTN,DIKCITL,NS,XR) ;Build routine DIKCRTN
  1. N CV
  1. K ^UTILITY($J)
  1. D AD(DIKCRTN_" ;xxxx/"_DIKCITL_"-CREATE NEW-STYLE XREF ;")
  1. D AD(" ;;1.0")
  1. D AD(" ;")
  1. D AD(" N "_NS_"XR,"_NS_"RES,"_NS_"OUT")
  1. D BC(NS,XR,"FILE",0,1)
  1. D:$P($G(^DD("IX",XR,0)),U,8)="W" BC(NS,XR,"ROOT FILE",0,9)
  1. D BC(NS,XR,"NAME",0,2)
  1. D BC(NS,XR,"TYPE",0,4)
  1. D BC(NS,XR,"USE",0,14)
  1. D BC(NS,XR,"EXECUTION",0,6)
  1. D BC(NS,XR,"ACTIVITY",0,7)
  1. D BC(NS,XR,"SHORT DESCR",0,3)
  1. D BCW(NS,XR,"DESCR",.1)
  1. D:$P($G(^DD("IX",XR,0)),U,4)="MU"
  1. . D BC(NS,XR,"SET",1)
  1. . D BC(NS,XR,"KILL",2)
  1. . D BC(NS,XR,"WHOLE KILL",2.5)
  1. D BC(NS,XR,"SET CONDITION",1.4)
  1. D BC(NS,XR,"KILL CONDITION",2.4)
  1. ;
  1. S CV=0 F S CV=$O(^DD("IX",XR,11.1,CV)) Q:'CV D
  1. . N ON,TP,VAL
  1. . S ON=$P($G(^DD("IX",XR,11.1,CV,0)),U) Q:'ON
  1. . S TP=$P($G(^DD("IX",XR,11.1,CV,0)),U,2)
  1. . I TP="F" D
  1. .. S VAL=$P($G(^DD("IX",XR,11.1,CV,0)),U,4) Q:'VAL
  1. .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_VAL)
  1. . E D
  1. .. S VAL=$G(^DD("IX",XR,11.1,CV,1.5)) Q:VAL=""
  1. .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_$$QT(VAL))
  1. . D BCC(NS,XR,CV,ON,"SUBSCRIPT",0,6)
  1. . D BCC(NS,XR,CV,ON,"LENGTH",0,5)
  1. . D BCC(NS,XR,CV,ON,"COLLATION",0,7)
  1. . D BCC(NS,XR,CV,ON,"LOOKUP PROMPT",0,8)
  1. . D:TP="F"
  1. .. D BCC(NS,XR,CV,ON,"XFORM FOR STORAGE",2)
  1. .. D BCC(NS,XR,CV,ON,"XFORM FOR LOOKUP",4)
  1. .. D BCC(NS,XR,CV,ON,"XFORM FOR DISPLAY",3)
  1. ;
  1. D AD(" D CREIXN^DDMOD(."_NS_"XR,""SW"",."_NS_"RES,"""_NS_"OUT"")")
  1. D AD(" Q")
  1. ;
  1. Q
  1. BC(NS,XR,SUB,ND,PC) ;Build code that sets an array element
  1. N VAL
  1. I $G(PC)="" S VAL=$G(^DD("IX",XR,ND))
  1. E S VAL=$P($G(^DD("IX",XR,ND)),U,PC)
  1. Q:VAL=""
  1. D AD(" S "_NS_"XR("""_SUB_""")="_$$QT(VAL))
  1. Q
  1. ;
  1. BCW(NS,XR,SUB,ND) ;Build code that sets array for wp field
  1. N I,VAL
  1. S I=0 F S I=$O(^DD("IX",XR,ND,I)) Q:'I D
  1. . S VAL=$G(^DD("IX",XR,ND,I,0)) S:VAL="" VAL=" "
  1. . D AD(" S "_NS_"XR("""_SUB_""","_I_")="_$$QT(VAL))
  1. Q
  1. ;
  1. BCC(NS,XR,CV,ON,SUB,ND,PC) ;Build code that sets an array element
  1. N VAL
  1. I $G(PC)="" S VAL=$G(^DD("IX",XR,11.1,CV,ND))
  1. E S VAL=$P($G(^DD("IX",XR,11.1,CV,ND)),U,PC)
  1. Q:VAL=""
  1. D AD(" S "_NS_"XR(""VAL"","_ON_","""_SUB_""")="_$$QT(VAL))
  1. Q
  1. ;
  1. QT(X) ;Return string X quoted, if noncanonic
  1. Q:$G(X)="" """"""
  1. Q:X=+$E($P(X,"E"),1,15) X
  1. S X(X)="",X=$Q(X(""))
  1. Q $E(X,3,$L(X)-1)
  1. ;
  1. N LN
  1. S LN=$O(^UTILITY($J,0," "),-1)+1
  1. S ^UTILITY($J,0,LN)=X
  1. Q
  1. ;
  1. SAVE(DIKCRTN) ;Save routine DIKCRTN
  1. N X,%Y
  1. S ^UTILITY($J,0,1)=^UTILITY($J,0,1)_$$NOW
  1. S X=DIKCRTN X ^DD("OS",DISYS,"ZS")
  1. W !!,$$EZBLD^DIALOG(8025,DIKCRTN)
  1. Q
  1. ;
  1. ASKRTN() ;Prompt for routine name; return ^ if timeout, null, or ^
  1. N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="FO^1:8^K:X?.E1.C.E!'(X?1""%""1.7AN!(X?1A1.7AN)) X"
  1. S DIR("A")="Routine name"
  1. S DIR("?",1)=" Enter the name of the routine, without the leading up-arrow, that"
  1. S DIR("?",2)=" should be built."
  1. S DIR("?",3)=""
  1. S DIR("?",4)=" Answer must be 1-8 characters in length. It must begin with % or a"
  1. S DIR("?")=" letter, followed by a combination of letters and numbers."
  1. F D Q:$G(DIKCRTN)]""
  1. . D ^DIR I $D(DIRUT) S DIKCRTN=U Q
  1. . S DIKCRTN=X
  1. . Q:$T(^@X)="" ; routine doesn't exist; overwrite okay. VEN/SMH
  1. . Q:$$ASKREPL(DIKCRTN)
  1. . S DIKCRTN=""
  1. Q $G(DIKCRTN)
  1. ;
  1. ASKREPL(DIKCRTN) ;Ask whether to replace the existing routine
  1. N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="YO"
  1. S DIR("A")=" Do you wish to replace routine "_DIKCRTN
  1. S DIR("B")="NO"
  1. S DIR("?")=" Answer yes if you wish to replace routine "_DIKCRTN_" with a new version."
  1. W !!," Routine "_DIKCRTN_" already exists."
  1. D ^DIR W !
  1. Q Y
  1. ;
  1. ASKITL() ;Ask for programmer initials
  1. N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="FO^1:15"
  1. S DIR("A")="Programmer initials"
  1. S DIR("?",1)=" Enter your initials, which will appear on the first line of the"
  1. S DIR("?")=" routine."
  1. D ^DIR
  1. Q Y
  1. ;
  1. ASKNMSP() ;Prompt for a namespace
  1. N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="FO^1:4^K:X?.E1.C.E!'(X?1""%""1.3AN!(X?1A1.3AN)) X"
  1. S DIR("A")="Namespace to use for local variables"
  1. S DIR("?",1)=" All variables used in the generated routine will start with the namespace"
  1. S DIR("?",2)=" you choose."
  1. S DIR("?",3)=""
  1. S DIR("?",4)=" Answer must be 1-4 characters in length. It must begin with % or a"
  1. S DIR("?")=" letter, followed by a combination of letters and numbers."
  1. D ^DIR
  1. Q Y
  1. ;
  1. ASKXR() ;Prompt for file/xref
  1. N DIKCCNT,DIKCROOT,DIKCTOP,DIKCFILE,DDS1,D,DIC,X,Y
  1. S DDS1="CROSS-REFERENCE FROM: " D W^DICRW Q:Y<0 ""
  1. S DIKCTOP=+$P($G(@(DIC_"0)")),U,2) Q:'DIKCTOP ""
  1. S DIKCFILE=$$SUB^DIKCU(DIKCTOP)
  1. ;
  1. D GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT)
  1. W ! D LIST^DIKCUTL2(.DIKCCNT)
  1. Q $$CHOOSE^DIKCUTL2(.DIKCCNT,"to build a routine for")
  1. ;
  1. NOW() ;Return current time in external form
  1. N %,%I,%H,AP,HR,MIN,MON,TIM,X
  1. D NOW^%DTC
  1. S TIM=$P(%,".",2)
  1. S HR=$E(TIM,1,2)
  1. S AP=$S(HR<12:"AM",1:"PM")
  1. S HR=$S(HR<13:+HR,1:HR#12)
  1. S MIN=$E(TIM_"0000",3,4)
  1. ;
  1. S MON=$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,%I(1))
  1. Q HR_":"_MIN_" "_AP_" "_%I(2)_" "_MON_" "_(%I(3)+1700)