- 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 Feb 19, 2025@00:14:57 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)