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 ---[H[J[2J[HXQSMDFM 4149 printed Apr 09, 2024@21:07:51 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
