XQSMDFM.m

XQSMDFM ;ISC-SF(SEA)/JLI,MJM - PERMIT USER TO BUILD LIMITED FM OPTIONS ;01/25/2008

 ;;8.0;KERNEL;**510**;Jul 10, 1995;Build 6

 ; Per VHA Directive 2004-038, this routine should not be modified.

 ; Option: XQSMD LIMITED FM OPTIONS

RULES ;

 N XQNMSP,XQTYPE

 D NAMESP^XQSMD4(.XQNMSP) Q:'$D(XQNMSP)  ; User must have namespace to use.

 D ASKTYPE(.XQTYPE) Q:'$D(XQTYPE)

 D @XQTYPE

 Q

ASKTYPE(XQTYPE) ;

 W !,"The option types that may be built are P(rint), E(dit), and I(nquire),"

 W !,"and you must have template(s) ready to be included in the option."

 W !,"You may also enter D(elete) to delete an option."

 N DIR,X,Y,DIRUT

 S DIR("A")="Select Option Type"

 S DIR(0)="S^E:Edit"

 S DIR(0)=DIR(0)_";P:Print"

 S DIR(0)=DIR(0)_";I:Inquire"

 S DIR(0)=DIR(0)_";D:Delete"

 D ^DIR Q:$D(DIRUT)

 S XQTYPE=Y

 Q

D ; Delete

 N DIC,X,Y,XQOPT

 S DIC("A")="Select Option to Delete: "

 S DIC(0)="AEQMZ"

 S DIC="^VA(200,DUZ,19.5,"

 D ^DIC Q:Y<0

 S XQOPT("IEN")=+Y ; Option IEN

 S XQOPT("NAME")=Y(0,0) ; Option Name

 I $D(^VA(200,"AP",XQOPT("IEN"))) D NODEL^XQSMD4(.XQOPT) Q

 N DIR,X,Y,DIRUT

 S DIR("A")="Do you really want to delete "_XQOPT("NAME")

 S DIR("B")="No"

 S DIR(0)="Y"

 D ^DIR Q:'Y

 D DELETE^XQSMD4(.XQOPT)

 Q

E ; Edit

 N XQTMPLE,DIR,X,Y,DIRUT,DR

 D ASKTMPL("Edit","^DIE(",.XQTMPLE) Q:'$D(XQTMPLE)

 S DIR(0)="Y"

 S DIR("A")="Should the user be allowed to ADD a new "_XQTMPLE("FNAME")_" file entry"

 S DIR("B")="No"

 D ^DIR Q:$D(DIRUT)

 S XQTMPLE("ADD")=Y

 S DR="1;3.5;4///E;30///"_XQTMPLE("FGLOB")_";31///AEMQ"_$S(XQTMPLE("ADD"):"L",1:"")_";50///"_XQTMPLE("FGLOB")_";51///["_XQTMPLE("NAME")_"];"

 D CRE8OPT(DR)

 Q

I ; Inquire

 N XQTMPLP,DR

 D ASKTMPL("Print","^DIPT(",.XQTMPLP,1) Q:'$D(XQTMPLP)

 S DR="1;3.5;4///I;30///"_XQTMPLP("FGLOB")_";31///AEMQ;80///"_XQTMPLP("FGLOB")_";"

 I $D(XQTMPLP("NAME")) S DR=DR_"63///["_XQTMPLP("NAME")_"];"

 D CRE8OPT(DR)

 Q

P ; Print

 N XQTMPLP,XQTMPLS,DR

 D ASKTMPL("Sort","^DIBT(",.XQTMPLS) Q:'$D(XQTMPLS)

 S XQTMPLP("FNUM")=XQTMPLS("FNUM"),XQTMPLP("FNAME")=XQTMPLS("FNAME"),XQTMPLP("FGLOB")=XQTMPLS("FGLOB")

 D ASKTMPL("Print","^DIPT(",.XQTMPLP) Q:'$D(XQTMPLP)

 S DR="1;3.5;4///P;60///"_XQTMPLP("FGLOB")_";62///0;63///["_XQTMPLP("NAME")_"];64///["_XQTMPLS("NAME")_"];"

 D CRE8OPT(DR)

 Q

ASKTMPL(XQADJ,XQFILE,XQTMPL,XQOPTNL) ;

 N DIC,X,Y,DTOUT,DUOUT

 I '$D(XQTMPL("FNUM")) D ASKFILE(.XQTMPL) Q:'$D(XQTMPL("FNUM"))

 S DIC("A")="Select "_XQADJ_" Template"_$S($G(XQOPTNL):" (Optional)",1:"")_": "

 S DIC("S")="I $P(^(0),U,4)="_XQTMPL("FNUM")

 S DIC(0)="AEQMZ"

 S DIC=XQFILE

 D ^DIC I Y<0 D  Q

 . I '$G(XQOPTNL) K XQTMPL Q

 . I $D(DUOUT)!$D(DTOUT) K XQTMPL

 S XQTMPL("NAME")=Y(0,0) ; Template Name

 ;S XQTMPL("FNUM")=$P(Y(0),U,4) ; File Number

 ;S XQTMPL("FNAME")=$P(^DIC(XQTMPL("FNUM"),0),U) ; File Name

 Q

ASKFILE(XQTMPL) ;

 N DIC,X,Y

 S DIC=1

 S DIC(0)="AEQM"

 S DIC("S")="I $$ACCESS^XQSMDFM(+Y)"

 D ^DIC Q:Y<0

 S XQTMPL("FNUM")=+Y

 S XQTMPL("FNAME")=$P(Y,U,2)

 S XQTMPL("FGLOB")=$P(^DIC(XQTMPL("FNUM"),0,"GL"),U,2)

 Q

CRE8OPT(DR) ;

 N DIE,DA,XQOPT,DIC,DLAYGO,X

AGAIN ;

 D ASKOPT^XQSMD4(.XQOPT,XQTYPE) Q:'$D(XQOPT)

 I 'XQOPT("NEW") I '$$SURE K XQOPT G AGAIN

 S DIE=19,DA=XQOPT("IEN") D ^DIE

 S DIC="^VA(200,DUZ,19.5,",X=XQOPT("NAME"),DIC(0)="MLX",DA(1)=DUZ,DLAYGO=200 D ^DIC

 Q

SURE() ;

 N DIR,X,Y,XQT

 S XQT=$P(^DIC(19,XQOPT("IEN"),0),U,4)

 W !,"This is an existing "_$$TYPE^XQSMD4(XQT)_" option."

 I '$D(^VA(200,DUZ,19.5,XQOPT("IEN"),0)) W !,$C(7),"It is not included in your delegated options." Q 0

 I XQT'=XQTYPE W !,"It may not be changed to a different type of option." Q 0

 S DIR("A")="Are you sure you wish to change it?"

 S DIR("B")="No"

 D ^DIR

 Q Y

ACCESS(XQFNUM) ; See if user has file access

 N XQYZ,XQNODE,XQPIECE

 I XQTYPE="E" S XQNODE="WR",XQPIECE=6

 E  S XQNODE="RD",XQPIECE=5

 S XQYZ=$G(^DIC(XQFNUM,0,XQNODE)) Q:XQYZ="" 1

 I $D(^VA(200,"AFOF")) Q $P($G(^VA(200,DUZ,"FOF",XQFNUM,0)),U,XQPIECE)>0

 ;If Part 3 hasn't been run, check old style FM access codes

 N XQACC,XQFMA,I

 S XQACC=0

 S XQFMA=$P(^VA(200,DUZ,0),U,4) Q:XQFMA="" 0

 F I=1:1:$L(XQFMA) I XQYZ[$E(XQFMA,I) S XQACC=1 Q

 Q XQACC

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XQSMDFM   4149     printed  Mar 13, 2025@21:11:31                                                                                                                                                                                                     Page 2

XQSMDFM   ;ISC-SF(SEA)/JLI,MJM - PERMIT USER TO BUILD LIMITED FM OPTIONS ;01/25/2008

 +1       ;;8.0;KERNEL;**510**;Jul 10, 1995;Build 6

 +2       ; Per VHA Directive 2004-038, this routine should not be modified.

 +3       ; Option: XQSMD LIMITED FM OPTIONS

RULES     ;

 +1        NEW XQNMSP,XQTYPE

 +2       ; User must have namespace to use.

           DO NAMESP^XQSMD4(.XQNMSP)

           if '$DATA(XQNMSP)

               QUIT 

 +3        DO ASKTYPE(.XQTYPE)

           if '$DATA(XQTYPE)

               QUIT 

 +4        DO @XQTYPE

 +5        QUIT 

ASKTYPE(XQTYPE) ;

 +1        WRITE !,"The option types that may be built are P(rint), E(dit), and I(nquire),"

 +2        WRITE !,"and you must have template(s) ready to be included in the option."

 +3        WRITE !,"You may also enter D(elete) to delete an option."

 +4        NEW DIR,X,Y,DIRUT

 +5        SET DIR("A")="Select Option Type"

 +6        SET DIR(0)="S^E:Edit"

 +7        SET DIR(0)=DIR(0)_";P:Print"

 +8        SET DIR(0)=DIR(0)_";I:Inquire"

 +9        SET DIR(0)=DIR(0)_";D:Delete"

 +10       DO ^DIR

           if $DATA(DIRUT)

               QUIT 

 +11       SET XQTYPE=Y

 +12       QUIT 

D         ; Delete

 +1        NEW DIC,X,Y,XQOPT

 +2        SET DIC("A")="Select Option to Delete: "

 +3        SET DIC(0)="AEQMZ"

 +4        SET DIC="^VA(200,DUZ,19.5,"

 +5        DO ^DIC

           if Y<0

               QUIT 

 +6       ; Option IEN

           SET XQOPT("IEN")=+Y

 +7       ; Option Name

           SET XQOPT("NAME")=Y(0,0)

 +8        IF $DATA(^VA(200,"AP",XQOPT("IEN")))

               DO NODEL^XQSMD4(.XQOPT)

               QUIT 

 +9        NEW DIR,X,Y,DIRUT

 +10       SET DIR("A")="Do you really want to delete "_XQOPT("NAME")

 +11       SET DIR("B")="No"

 +12       SET DIR(0)="Y"

 +13       DO ^DIR

           if 'Y

               QUIT 

 +14       DO DELETE^XQSMD4(.XQOPT)

 +15       QUIT 

E         ; Edit

 +1        NEW XQTMPLE,DIR,X,Y,DIRUT,DR

 +2        DO ASKTMPL("Edit","^DIE(",.XQTMPLE)

           if '$DATA(XQTMPLE)

               QUIT 

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="Should the user be allowed to ADD a new "_XQTMPLE("FNAME")_" file entry"

 +5        SET DIR("B")="No"

 +6        DO ^DIR

           if $DATA(DIRUT)

               QUIT 

 +7        SET XQTMPLE("ADD")=Y

 +8        SET DR="1;3.5;4///E;30///"_XQTMPLE("FGLOB")_";31///AEMQ"_$SELECT(XQTMPLE("ADD"):"L",1:"")_";50///"_XQTMPLE("FGLOB")_";51///["_XQTMPLE("NAME")_"];"

 +9        DO CRE8OPT(DR)

 +10       QUIT 

I         ; Inquire

 +1        NEW XQTMPLP,DR

 +2        DO ASKTMPL("Print","^DIPT(",.XQTMPLP,1)

           if '$DATA(XQTMPLP)

               QUIT 

 +3        SET DR="1;3.5;4///I;30///"_XQTMPLP("FGLOB")_";31///AEMQ;80///"_XQTMPLP("FGLOB")_";"

 +4        IF $DATA(XQTMPLP("NAME"))

               SET DR=DR_"63///["_XQTMPLP("NAME")_"];"

 +5        DO CRE8OPT(DR)

 +6        QUIT 

P         ; Print

 +1        NEW XQTMPLP,XQTMPLS,DR

 +2        DO ASKTMPL("Sort","^DIBT(",.XQTMPLS)

           if '$DATA(XQTMPLS)

               QUIT 

 +3        SET XQTMPLP("FNUM")=XQTMPLS("FNUM")

           SET XQTMPLP("FNAME")=XQTMPLS("FNAME")

           SET XQTMPLP("FGLOB")=XQTMPLS("FGLOB")

 +4        DO ASKTMPL("Print","^DIPT(",.XQTMPLP)

           if '$DATA(XQTMPLP)

               QUIT 

 +5        SET DR="1;3.5;4///P;60///"_XQTMPLP("FGLOB")_";62///0;63///["_XQTMPLP("NAME")_"];64///["_XQTMPLS("NAME")_"];"

 +6        DO CRE8OPT(DR)

 +7        QUIT 

ASKTMPL(XQADJ,XQFILE,XQTMPL,XQOPTNL) ;

 +1        NEW DIC,X,Y,DTOUT,DUOUT

 +2        IF '$DATA(XQTMPL("FNUM"))

               DO ASKFILE(.XQTMPL)

               if '$DATA(XQTMPL("FNUM"))

                   QUIT 

 +3        SET DIC("A")="Select "_XQADJ_" Template"_$SELECT($GET(XQOPTNL):" (Optional)",1:"")_": "

 +4        SET DIC("S")="I $P(^(0),U,4)="_XQTMPL("FNUM")

 +5        SET DIC(0)="AEQMZ"

 +6        SET DIC=XQFILE

 +7        DO ^DIC

           IF Y<0

               Begin DoDot:1

 +8                IF '$GET(XQOPTNL)

                       KILL XQTMPL

                       QUIT 

 +9                IF $DATA(DUOUT)!$DATA(DTOUT)

                       KILL XQTMPL

               End DoDot:1

               QUIT 

 +10      ; Template Name

           SET XQTMPL("NAME")=Y(0,0)

 +11      ;S XQTMPL("FNUM")=$P(Y(0),U,4) ; File Number

 +12      ;S XQTMPL("FNAME")=$P(^DIC(XQTMPL("FNUM"),0),U) ; File Name

 +13       QUIT 

ASKFILE(XQTMPL) ;

 +1        NEW DIC,X,Y

 +2        SET DIC=1

 +3        SET DIC(0)="AEQM"

 +4        SET DIC("S")="I $$ACCESS^XQSMDFM(+Y)"

 +5        DO ^DIC

           if Y<0

               QUIT 

 +6        SET XQTMPL("FNUM")=+Y

 +7        SET XQTMPL("FNAME")=$PIECE(Y,U,2)

 +8        SET XQTMPL("FGLOB")=$PIECE(^DIC(XQTMPL("FNUM"),0,"GL"),U,2)

 +9        QUIT 

CRE8OPT(DR) ;

 +1        NEW DIE,DA,XQOPT,DIC,DLAYGO,X

AGAIN     ;

 +1        DO ASKOPT^XQSMD4(.XQOPT,XQTYPE)

           if '$DATA(XQOPT)

               QUIT 

 +2        IF 'XQOPT("NEW")

               IF '$$SURE

                   KILL XQOPT

                   GOTO AGAIN

 +3        SET DIE=19

           SET DA=XQOPT("IEN")

           DO ^DIE

 +4        SET DIC="^VA(200,DUZ,19.5,"

           SET X=XQOPT("NAME")

           SET DIC(0)="MLX"

           SET DA(1)=DUZ

           SET DLAYGO=200

           DO ^DIC

 +5        QUIT 

SURE()    ;

 +1        NEW DIR,X,Y,XQT

 +2        SET XQT=$PIECE(^DIC(19,XQOPT("IEN"),0),U,4)

 +3        WRITE !,"This is an existing "_$$TYPE^XQSMD4(XQT)_" option."

 +4        IF '$DATA(^VA(200,DUZ,19.5,XQOPT("IEN"),0))

               WRITE !,$CHAR(7),"It is not included in your delegated options."

               QUIT 0

 +5        IF XQT'=XQTYPE

               WRITE !,"It may not be changed to a different type of option."

               QUIT 0

 +6        SET DIR("A")="Are you sure you wish to change it?"

 +7        SET DIR("B")="No"

 +8        DO ^DIR

 +9        QUIT Y

ACCESS(XQFNUM) ; See if user has file access

 +1        NEW XQYZ,XQNODE,XQPIECE

 +2        IF XQTYPE="E"

               SET XQNODE="WR"

               SET XQPIECE=6

 +3       IF '$TEST

               SET XQNODE="RD"

               SET XQPIECE=5

 +4        SET XQYZ=$GET(^DIC(XQFNUM,0,XQNODE))

           if XQYZ=""

               QUIT 1

 +5        IF $DATA(^VA(200,"AFOF"))

               QUIT $PIECE($GET(^VA(200,DUZ,"FOF",XQFNUM,0)),U,XQPIECE)>0

 +6       ;If Part 3 hasn't been run, check old style FM access codes

 +7        NEW XQACC,XQFMA,I

 +8        SET XQACC=0

 +9        SET XQFMA=$PIECE(^VA(200,DUZ,0),U,4)

           if XQFMA=""

               QUIT 0

 +10       FOR I=1:1:$LENGTH(XQFMA)

               IF XQYZ[$EXTRACT(XQFMA,I)

                   SET XQACC=1

                   QUIT 

 +11       QUIT XQACC