ORACCES2 ;SLC/JNM - User Read/Write Access to CPRS ; Feb 08, 2023@13:54
;;3.0;ORDER ENTRY/RESULTS REPORTING;**588**;Dec 17, 1997;Build 29
;
; Reference to ^XTV(8989.5,"AC" in ICR #2686
Q
;
ACCESS(RESULTS,USER,GETNOTES,NOTES) ;
; NOTES only populated if GETNOTES>0
; GETNOTES=1 Adds just the missing dependencies
; GETNOTES=2 Adds the entire description
N CNT,CNT2,IEN,IENARR,NODE,ORERR,ORVALUE,TAB,VALUE,X,SORT,COUNT,PARAM,LASTPARAM,SHOW
N ORPARAM,ORTABS,CPRS,WRITE,TEMPLATE,DG,TABS,OTHER,ORDERS,ERROR,NCNT,MAXGROUPS,SHOWEXCLUDE
N ORDERSTAB,ALLERGIESTAB,NOTESTAB,DELAYEDORDERSTAB,IMMUNIZATIONSTAB,ENCOUNTERSTAB
D GETPARAMS^ORACCESS
S CPRS="cprsAccess",WRITE="writeAccess",TEMPLATE="templateAccess",DG="displayGroups"
S SORT="SORT",MAXGROUPS=0
S ORDERSTAB=$$TABIDX^ORACCESS(TABS,"O"),ALLERGIESTAB=$$TABIDX^ORACCESS(OTHER,"A")
S NOTESTAB=$$TABIDX^ORACCESS(TABS,"N"),DELAYEDORDERSTAB=$$TABIDX^ORACCESS(OTHER,"D")
S IMMUNIZATIONSTAB=$$TABIDX^ORACCESS(OTHER,"I"),ENCOUNTERSTAB=$$TABIDX^ORACCESS(OTHER,"E")
S GETNOTES=+$G(GETNOTES) K NOTES
S RESULTS(CPRS,"errorMessage")=$$GET^XPAR("ALL",ORPARAM(ERROR))
;get tabs values
S TAB=0 F S TAB=$O(ORTABS(TAB)) Q:'TAB D
.S VALUE=$$GET^XPAR("ALL",ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2))
.I VALUE="" S VALUE=0
.S RESULTS(CPRS,ORTABS(TAB,3),WRITE)=VALUE
.I ORTABS(TAB,5)=1 S RESULTS(CPRS,ORTABS(TAB,3),TEMPLATE)=VALUE
.I GETNOTES=2,TAB'=ORDERSTAB,TAB'=DELAYEDORDERSTAB D
..S NOTES(SORT,ORTABS(TAB,1)_$$TABDESC^ORACCESS(TAB,1))=VALUE
;get Order Display Groups Write Access
I RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=1 D
.S (CNT,CNT2)=0
.F X="PKG","SYS","DIV","USR" D
..K ORVALUE,ORERR
..D GETLST^XPAR(.ORVALUE,X,ORPARAM(ORDERS),"I",.ORERR)
..S IEN=0 F S IEN=$O(ORVALUE(IEN)) Q:IEN'>0 D
...S VALUE=ORVALUE(IEN)
...S NODE=$G(^ORD(100.98,IEN,0)) I NODE="" Q
...I X="PKG" D Q
....S CNT=CNT+1,CNT2=CNT
....S IENARR(IEN)=VALUE_U_CNT
....D ADDGROUPRESULTS
...I $D(IENARR(IEN)),+IENARR(IEN)=VALUE Q
...I $D(IENARR(IEN)) S $P(IENARR(IEN),U,1)=VALUE,CNT=$P(IENARR(IEN),U,2)
...E S CNT2=CNT2+1,CNT=CNT2,IENARR(IEN)=VALUE_U_CNT
...D ADDGROUPRESULTS
.; Add any missing groups
.S VALUE=1,IEN=0 F S IEN=$O(^ORD(100.98,IEN)) Q:'IEN D
..S NODE=$G(^ORD(100.98,IEN,0)),MAXGROUPS=MAXGROUPS+1 I '$D(IENARR(IEN)) D
...S CNT2=CNT2+1,CNT=CNT2,IENARR(IEN)=VALUE_U_CNT
...D ADDGROUPRESULTS
.I GETNOTES=2 D
..F X=1:1:CNT2 D
...S NOTES(SORT,3_RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,X,"name"))=RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,X,WRITE)
;
I RESULTS(CPRS,ORTABS(ALLERGIESTAB,3),WRITE)=1 D
.N MSG
.I RESULTS(CPRS,ORTABS(NOTESTAB,3),WRITE)=0 S MSG=ORTABS(NOTESTAB,4)_" tab"
.I RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=0 D I 1
..I $D(MSG) S MSG=MSG_" and "
..S MSG=$G(MSG)_ORTABS(ORDERSTAB,4)_" tab"
.E D
..S IEN=$O(^ORD(100.98,"B","ALLERGIES",0))
..I IEN,$D(IENARR(IEN)),$P(IENARR(IEN),U)=0 D
...I $D(MSG) S MSG=MSG_" and "
...S MSG=$G(MSG)_"ALLERGIES display group"
.I $D(MSG) D
..S RESULTS(CPRS,ORTABS(ALLERGIESTAB,3),WRITE)=0
..I GETNOTES>0 S NOTES(SORT,4_ORTABS(ALLERGIESTAB,4)_" requires "_MSG_" access")=1
..I GETNOTES=2 S NOTES(SORT,ORTABS(ALLERGIESTAB,1)_$$TABDESC^ORACCESS(ALLERGIESTAB,1))=0
;
I RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=1,RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=0 D
.S RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=0
.I GETNOTES>0 S NOTES(SORT,4_ORTABS(DELAYEDORDERSTAB,4)_" requires "_ORTABS(ORDERSTAB,4)_" tab access")=1
.;I GETNOTES=2 S NOTES(SORT,ORTABS(DELAYEDORDERSTAB,1)_$$TABDESC^ORACCESS(DELAYEDORDERSTAB,1))=0
;
I RESULTS(CPRS,ORTABS(IMMUNIZATIONSTAB,3),WRITE)=1 D
.N MSG
.I RESULTS(CPRS,ORTABS(NOTESTAB,3),WRITE)=0 S MSG=ORTABS(NOTESTAB,4)_" tab"
.I RESULTS(CPRS,ORTABS(ENCOUNTERSTAB,3),WRITE)=0 D
..I $D(MSG) S MSG=MSG_" and "
..S MSG=$G(MSG)_ORTABS(ENCOUNTERSTAB,4)
.I $D(MSG) D
..S RESULTS(CPRS,ORTABS(IMMUNIZATIONSTAB,3),WRITE)=0
..I GETNOTES>0 S NOTES(SORT,4_ORTABS(IMMUNIZATIONSTAB,4)_" requires "_MSG_" access")=1
..I GETNOTES=2 S NOTES(SORT,ORTABS(IMMUNIZATIONSTAB,1)_$$TABDESC^ORACCESS(IMMUNIZATIONSTAB,1))=0
;
I GETNOTES>0 D
.N MSG S SHOWEXCLUDE=0
.I GETNOTES=2,RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=1 D
..S MSG=ORTABS(ORDERSTAB,1)_$$TABDESC^ORACCESS(ORDERSTAB,1)_", delayed orders "
..I RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=0 S MSG=MSG_"not "
..S MSG=MSG_"allowed",NOTES(SORT,MSG)=1
.S (NCNT,LASTPARAM)=0 F PARAM=1:1:4 S COUNT(PARAM)=0
.S NODE="" F S NODE=$O(NOTES(SORT,NODE)) Q:NODE="" D
..S PARAM=+$E(NODE,1,1) I +NOTES(SORT,NODE) S COUNT(PARAM)=COUNT(PARAM)+1
.S NODE="" F S NODE=$O(NOTES(SORT,NODE)) Q:NODE="" D
..S PARAM=+$E(NODE,1,1)
..I PARAM'=LASTPARAM D
...N IDX,MSGOUT S MSG=""
...S LASTPARAM=PARAM
...I NCNT>0 S NCNT=NCNT+1,NOTES(NCNT)=""
...I COUNT(PARAM)=0 D I 1
....I PARAM<3 D
.....N MSGSORT,CNT,MAX S (IDX,CNT,MAX)=0
.....F S IDX=$O(ORTABS(IDX)) Q:'IDX I IDX'=DELAYEDORDERSTAB,ORTABS(IDX,1)=PARAM S MAX=MAX+1
.....S IDX=0 F S IDX=$O(ORTABS(IDX)) Q:'IDX I IDX'=DELAYEDORDERSTAB,ORTABS(IDX,1)=PARAM D
......S MSGSORT($$TABDESC^ORACCESS(IDX,$S(ORTABS(IDX,5)=2:1,1:0)))=""
.....S IDX="" F S IDX=$O(MSGSORT(IDX)) Q:IDX="" D
......S CNT=CNT+1 I MSG'="" S MSG=MSG_$S(CNT<MAX:", ",1:" or ")
......S MSG=MSG_IDX
.....I PARAM=1 S MSG=MSG_" tabs"
....I PARAM=3 S MSG="any display groups"
....S MSG="No write access for "_MSG_"."
....D WRAP^ORUTL(MSG,"MSGOUT",1,0,3,0,78)
....S IDX=0 F S IDX=$O(MSGOUT(IDX)) Q:'IDX D
.....S NCNT=NCNT+1,NOTES(NCNT)=MSGOUT(IDX)
...E D ; COUNT(PARAM)>0
....S NCNT=NCNT+1
....I PARAM=1 S NOTES(NCNT)="Write access allowed for the following tab"_$S(COUNT(PARAM)>1:"s",1:"")_":"
....I PARAM=2 S NOTES(NCNT)="Write access allowed for the following additional functionality:"
....I PARAM=3 D
.....S SHOWEXCLUDE=(COUNT(PARAM)<MAXGROUPS)&(COUNT(PARAM)>(MAXGROUPS/2))
.....I COUNT(PARAM)<MAXGROUPS D
......I SHOWEXCLUDE S NOTES(NCNT)="Ordering write access allowed for all display groups EXCEPT:"
......E S NOTES(NCNT)="Ordering write access allowed for the following display group"_$S(COUNT(PARAM)>1:"s",1:"")_":"
.....E S NOTES(NCNT)="Ordering write access allowed for all display groups."
....I PARAM=4 S NOTES(NCNT)="Missing write access dependenc"_$S(COUNT(PARAM)=1:"y",1:"ies")_":"
..S SHOW=(NOTES(SORT,NODE)>0) I PARAM=3,SHOWEXCLUDE S SHOW='SHOW
..I SHOW,(PARAM'=3)!(COUNT(PARAM)<MAXGROUPS) D
...S NCNT=NCNT+1,NOTES(NCNT)=" "_$E(NODE,2,999)
.K NOTES(SORT)
Q
;
ADDGROUPRESULTS ;
S RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"ien")=IEN
S RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"name")=$P(NODE,U)
S RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"shortName")=$P(NODE,U,3)
S RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,WRITE)=VALUE
Q
;
VALUEMSG(ENT,INST,X,GETALL,MESSAGE,NAME) ;
I +$G(NODEPENDENCIES) Q
S GETALL=+$G(GETALL)
I $G(ENT)="" Q
I 'GETALL,$G(X)'="YES" Q
I $P($G(DIR(0)),U,3)'="" Q
N CODE
S CODE=$P($G(INST),U)
I 'GETALL,"^A^D^I^"'[(U_CODE_U) Q
N ORPARAM,ORPIEN,ORTABS,TABS,OTHER,ORDERS,ERROR,IEN,MCNT
N ORDERSTAB,ALLERGIESTAB,NOTESTAB,DELAYEDORDERSTAB,IMMUNIZATIONSTAB,ENCOUNTERSTAB
D GETPARAMS^ORACCESS(1)
S MCNT=0
S ORDERSTAB=$$TABIDX^ORACCESS(TABS,"O"),ALLERGIESTAB=$$TABIDX^ORACCESS(OTHER,"A")
S NOTESTAB=$$TABIDX^ORACCESS(TABS,"N"),DELAYEDORDERSTAB=$$TABIDX^ORACCESS(OTHER,"D")
S IMMUNIZATIONSTAB=$$TABIDX^ORACCESS(OTHER,"I"),ENCOUNTERSTAB=$$TABIDX^ORACCESS(OTHER,"E")
I GETALL S CODE=$S(+$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(ALLERGIESTAB,1)),ENT,ORTABS(ALLERGIESTAB,2))):"A",1:"")
I CODE="A" D
.N MSG
.I +$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(NOTESTAB,1)),ENT,ORTABS(NOTESTAB,2)))=0 D
..S MSG=ORTABS(NOTESTAB,4)_" tab"
.I +$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(ORDERSTAB,1)),ENT,ORTABS(ORDERSTAB,2)))=0 D I 1
..I $D(MSG) S MSG=MSG_" and "
..S MSG=$G(MSG)_ORTABS(ORDERSTAB,4)_" tab"
.E D
..S IEN=$O(^ORD(100.98,"B","ALLERGIES",0))
..I IEN,+$G(^XTV(8989.5,"AC",ORPIEN(ORDERS),ENT,IEN))=0 D
...I $D(MSG) S MSG=MSG_" and "
...S MSG=$G(MSG)_"ALLERGIES display group"
.I $D(MSG) D
..S MCNT=MCNT+1,MESSAGE(MCNT)=" "_ORTABS(ALLERGIESTAB,4)_" also requires "_MSG_" access."
I GETALL S CODE=$S(+$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(DELAYEDORDERSTAB,1)),ENT,ORTABS(DELAYEDORDERSTAB,2))):"D",1:"")
I CODE="D" D
.I +$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(ORDERSTAB,1)),ENT,ORTABS(ORDERSTAB,2)))=0 D
..S MCNT=MCNT+1,MESSAGE(MCNT)=" "_ORTABS(DELAYEDORDERSTAB,4)_" also requires "_ORTABS(ORDERSTAB,4)_" tab access."
I GETALL S CODE=$S(+$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(IMMUNIZATIONSTAB,1)),ENT,ORTABS(IMMUNIZATIONSTAB,2))):"I",1:"")
I CODE="I" D
.N MSG
.I +$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(NOTESTAB,1)),ENT,ORTABS(NOTESTAB,2)))=0 D
..S MSG=ORTABS(NOTESTAB,4)_" tab"
.I +$G(^XTV(8989.5,"AC",ORPIEN(ORTABS(ENCOUNTERSTAB,1)),ENT,ORTABS(ENCOUNTERSTAB,2)))=0 D
..I $D(MSG) S MSG=MSG_" and "
..S MSG=$G(MSG)_ORTABS(ENCOUNTERSTAB,4)
.I $D(MSG) D
..S MCNT=MCNT+1,MESSAGE(MCNT)=" "_ORTABS(IMMUNIZATIONSTAB,4)_" also requires "_MSG_" access."
I MCNT>0 D
.I GETALL D
..S MESSAGE(0.5)="Missing write access dependenc"_$S(MCNT=1:"y",1:"ies")_"* for "_$G(NAME)
..S MESSAGE(999)="* Dependencies may be resolved at a different level."
.I 'GETALL S IEN=0 F S IEN=$O(MESSAGE(IEN)) Q:'IEN W !,MESSAGE(IEN)
Q
;
DLGOIINFO(ORY,LIST,INFO) ; Return orderable item info tied to each order dialog in the list
; INFO=1 Get LAB SECTION
I '+$G(INFO) Q
N IDX,DLG,OI,OIIDX,SUBIDX,CODE,LINE
S OIIDX=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) I 'OIIDX Q
S (LINE,IDX)=0 F S IDX=$O(LIST(IDX)) Q:'IDX D
. S (OI,SUBIDX)=0 F S SUBIDX=$O(^ORD(101.41,LIST(IDX),6,SUBIDX)) Q:'SUBIDX D Q:OI
. . I $P($G(^ORD(101.41,LIST(IDX),6,SUBIDX,0)),U,2)=OIIDX D Q
. . . S OI=$P($G(^ORD(101.41,LIST(IDX),6,SUBIDX,1)),U,1)
. I OI D
. . S CODE=""
. . I INFO=1 S CODE=$P($G(^ORD(101.43,OI,"LR")),U,6) I CODE="" S CODE="CH"
. . I CODE'="" S LINE=LINE+1,ORY(LINE)=LIST(IDX)_U_CODE
Q
;
LABSBYXREF(ORY,DGSNAME) ; Return all LAB SECTION codes used by the specified XREF
S ORY=U
N XREF S XREF="S."_DGSNAME
I "^S.LAB^S.AP^"'[(U_$G(XREF)_U) Q
N DG,I,CODE,NAME,TEMP,LST,ILST,LIST,OUTPUT,ISAP,QUIT,APDLGIEN,X,CURTM
S CURTM=$$NOW^XLFDT,ISAP=(XREF="S.AP")
S NAME="" F S NAME=$O(^ORD(101.43,XREF,NAME)) Q:NAME="" D
. S I=0 F S I=$O(^ORD(101.43,XREF,NAME,I)) Q:'I D
. . S X=$G(^ORD(101.43,XREF,NAME,I))
. . I +$P(X,U,3),$P(X,U,3)<CURTM Q
. . I $P(X,U,5) Q
. . I ISAP D Q:QUIT
. . . S QUIT=1
. . . I '$$OK4CPRS^ORWLRAP1(I) Q
. . . S APDLGIEN=+$O(^ORD(101.45,"C",I,0)) I 'APDLGIEN Q
. . . I +$P($G(^ORD(101.45,APDLGIEN,0)),U,6) Q
. . . S QUIT=0
. . S CODE=$P($G(^ORD(101.43,I,"LR")),U,6)
. . I CODE="" S CODE="CH"
. . I '$D(TEMP(CODE)) S TEMP(CODE)=""
S ILST=0
I XREF="S.LAB" D SHORT^ORWDLR32 ; Also get any codes used by quick orders
I $D(LST) D
. S I=0 F S I=$O(LST(I)) Q:'I S LST(I)=$E($P(LST(I),U,1),3,999)
. D DLGOIINFO(.LIST,.LST,1)
. S I=0 F S I=$O(LIST(I)) Q:'I D
. . S CODE=$P(LIST(I),U,2) I CODE'="" S TEMP(CODE)=""
S I="" F S I=$O(TEMP(I)) Q:I="" S ORY=ORY_I_U
Q
;
DIETINFO(ORY) ; Return Diet Order Dialog info used to write access
N IDX,NAME,IDX,X0,DG,TYPE,CNT,LIST,FORMS,FCNT
S (CNT,FCNT)=0
D ADD2ORY("DIETETICS")
S NAME="FHW" F S NAME=$O(^ORD(101.41,"B",NAME)) Q:$E(NAME,1,3)'="FHW" D
. S IDX=0 F S IDX=$O(^ORD(101.41,"B",NAME,IDX)) Q:'IDX D
. . S X0=$G(^ORD(101.41,IDX,0)) I $P(X0,U,4)'="D" Q
. . S DG=$P(X0,U,5) I '+DG Q
. . S TYPE="" D FINDTYP^ORWDFH(.TYPE,DG) I $G(TYPE)="" Q
. . S FCNT=FCNT+1,FORMS(FCNT)=NAME_U_DG
. . S LIST(DG)=DG_U_TYPE_U_$P($G(^ORD(100.98,DG,0)),U,3)
S IDX=0 F S IDX=$O(LIST(IDX)) Q:'IDX D ADD2ORY(LIST(IDX))
;D ADD2ORY("-----")
;S IDX=0 F S IDX=$O(FORMS(IDX)) Q:'IDX D ADD2ORY(FORMS(IDX))
Q
;
ADD2ORY(TEXT) ;
S CNT=CNT+1,ORY(CNT)=TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORACCES2 11940 printed Apr 09, 2024@21:31:39 Page 2
ORACCES2 ;SLC/JNM - User Read/Write Access to CPRS ; Feb 08, 2023@13:54
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**588**;Dec 17, 1997;Build 29
+2 ;
+3 ; Reference to ^XTV(8989.5,"AC" in ICR #2686
+4 QUIT
+5 ;
ACCESS(RESULTS,USER,GETNOTES,NOTES) ;
+1 ; NOTES only populated if GETNOTES>0
+2 ; GETNOTES=1 Adds just the missing dependencies
+3 ; GETNOTES=2 Adds the entire description
+4 NEW CNT,CNT2,IEN,IENARR,NODE,ORERR,ORVALUE,TAB,VALUE,X,SORT,COUNT,PARAM,LASTPARAM,SHOW
+5 NEW ORPARAM,ORTABS,CPRS,WRITE,TEMPLATE,DG,TABS,OTHER,ORDERS,ERROR,NCNT,MAXGROUPS,SHOWEXCLUDE
+6 NEW ORDERSTAB,ALLERGIESTAB,NOTESTAB,DELAYEDORDERSTAB,IMMUNIZATIONSTAB,ENCOUNTERSTAB
+7 DO GETPARAMS^ORACCESS
+8 SET CPRS="cprsAccess"
SET WRITE="writeAccess"
SET TEMPLATE="templateAccess"
SET DG="displayGroups"
+9 SET SORT="SORT"
SET MAXGROUPS=0
+10 SET ORDERSTAB=$$TABIDX^ORACCESS(TABS,"O")
SET ALLERGIESTAB=$$TABIDX^ORACCESS(OTHER,"A")
+11 SET NOTESTAB=$$TABIDX^ORACCESS(TABS,"N")
SET DELAYEDORDERSTAB=$$TABIDX^ORACCESS(OTHER,"D")
+12 SET IMMUNIZATIONSTAB=$$TABIDX^ORACCESS(OTHER,"I")
SET ENCOUNTERSTAB=$$TABIDX^ORACCESS(OTHER,"E")
+13 SET GETNOTES=+$GET(GETNOTES)
KILL NOTES
+14 SET RESULTS(CPRS,"errorMessage")=$$GET^XPAR("ALL",ORPARAM(ERROR))
+15 ;get tabs values
+16 SET TAB=0
FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+17 SET VALUE=$$GET^XPAR("ALL",ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2))
+18 IF VALUE=""
SET VALUE=0
+19 SET RESULTS(CPRS,ORTABS(TAB,3),WRITE)=VALUE
+20 IF ORTABS(TAB,5)=1
SET RESULTS(CPRS,ORTABS(TAB,3),TEMPLATE)=VALUE
+21 IF GETNOTES=2
IF TAB'=ORDERSTAB
IF TAB'=DELAYEDORDERSTAB
Begin DoDot:2
+22 SET NOTES(SORT,ORTABS(TAB,1)_$$TABDESC^ORACCESS(TAB,1))=VALUE
End DoDot:2
End DoDot:1
+23 ;get Order Display Groups Write Access
+24 IF RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=1
Begin DoDot:1
+25 SET (CNT,CNT2)=0
+26 FOR X="PKG","SYS","DIV","USR"
Begin DoDot:2
+27 KILL ORVALUE,ORERR
+28 DO GETLST^XPAR(.ORVALUE,X,ORPARAM(ORDERS),"I",.ORERR)
+29 SET IEN=0
FOR
SET IEN=$ORDER(ORVALUE(IEN))
if IEN'>0
QUIT
Begin DoDot:3
+30 SET VALUE=ORVALUE(IEN)
+31 SET NODE=$GET(^ORD(100.98,IEN,0))
IF NODE=""
QUIT
+32 IF X="PKG"
Begin DoDot:4
+33 SET CNT=CNT+1
SET CNT2=CNT
+34 SET IENARR(IEN)=VALUE_U_CNT
+35 DO ADDGROUPRESULTS
End DoDot:4
QUIT
+36 IF $DATA(IENARR(IEN))
IF +IENARR(IEN)=VALUE
QUIT
+37 IF $DATA(IENARR(IEN))
SET $PIECE(IENARR(IEN),U,1)=VALUE
SET CNT=$PIECE(IENARR(IEN),U,2)
+38 IF '$TEST
SET CNT2=CNT2+1
SET CNT=CNT2
SET IENARR(IEN)=VALUE_U_CNT
+39 DO ADDGROUPRESULTS
End DoDot:3
End DoDot:2
+40 ; Add any missing groups
+41 SET VALUE=1
SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.98,IEN))
if 'IEN
QUIT
Begin DoDot:2
+42 SET NODE=$GET(^ORD(100.98,IEN,0))
SET MAXGROUPS=MAXGROUPS+1
IF '$DATA(IENARR(IEN))
Begin DoDot:3
+43 SET CNT2=CNT2+1
SET CNT=CNT2
SET IENARR(IEN)=VALUE_U_CNT
+44 DO ADDGROUPRESULTS
End DoDot:3
End DoDot:2
+45 IF GETNOTES=2
Begin DoDot:2
+46 FOR X=1:1:CNT2
Begin DoDot:3
+47 SET NOTES(SORT,3_RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,X,"name"))=RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,X,WRITE)
End DoDot:3
End DoDot:2
End DoDot:1
+48 ;
+49 IF RESULTS(CPRS,ORTABS(ALLERGIESTAB,3),WRITE)=1
Begin DoDot:1
+50 NEW MSG
+51 IF RESULTS(CPRS,ORTABS(NOTESTAB,3),WRITE)=0
SET MSG=ORTABS(NOTESTAB,4)_" tab"
+52 IF RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=0
Begin DoDot:2
+53 IF $DATA(MSG)
SET MSG=MSG_" and "
+54 SET MSG=$GET(MSG)_ORTABS(ORDERSTAB,4)_" tab"
End DoDot:2
IF 1
+55 IF '$TEST
Begin DoDot:2
+56 SET IEN=$ORDER(^ORD(100.98,"B","ALLERGIES",0))
+57 IF IEN
IF $DATA(IENARR(IEN))
IF $PIECE(IENARR(IEN),U)=0
Begin DoDot:3
+58 IF $DATA(MSG)
SET MSG=MSG_" and "
+59 SET MSG=$GET(MSG)_"ALLERGIES display group"
End DoDot:3
End DoDot:2
+60 IF $DATA(MSG)
Begin DoDot:2
+61 SET RESULTS(CPRS,ORTABS(ALLERGIESTAB,3),WRITE)=0
+62 IF GETNOTES>0
SET NOTES(SORT,4_ORTABS(ALLERGIESTAB,4)_" requires "_MSG_" access")=1
+63 IF GETNOTES=2
SET NOTES(SORT,ORTABS(ALLERGIESTAB,1)_$$TABDESC^ORACCESS(ALLERGIESTAB,1))=0
End DoDot:2
End DoDot:1
+64 ;
+65 IF RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=1
IF RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=0
Begin DoDot:1
+66 SET RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=0
+67 IF GETNOTES>0
SET NOTES(SORT,4_ORTABS(DELAYEDORDERSTAB,4)_" requires "_ORTABS(ORDERSTAB,4)_" tab access")=1
+68 ;I GETNOTES=2 S NOTES(SORT,ORTABS(DELAYEDORDERSTAB,1)_$$TABDESC^ORACCESS(DELAYEDORDERSTAB,1))=0
End DoDot:1
+69 ;
+70 IF RESULTS(CPRS,ORTABS(IMMUNIZATIONSTAB,3),WRITE)=1
Begin DoDot:1
+71 NEW MSG
+72 IF RESULTS(CPRS,ORTABS(NOTESTAB,3),WRITE)=0
SET MSG=ORTABS(NOTESTAB,4)_" tab"
+73 IF RESULTS(CPRS,ORTABS(ENCOUNTERSTAB,3),WRITE)=0
Begin DoDot:2
+74 IF $DATA(MSG)
SET MSG=MSG_" and "
+75 SET MSG=$GET(MSG)_ORTABS(ENCOUNTERSTAB,4)
End DoDot:2
+76 IF $DATA(MSG)
Begin DoDot:2
+77 SET RESULTS(CPRS,ORTABS(IMMUNIZATIONSTAB,3),WRITE)=0
+78 IF GETNOTES>0
SET NOTES(SORT,4_ORTABS(IMMUNIZATIONSTAB,4)_" requires "_MSG_" access")=1
+79 IF GETNOTES=2
SET NOTES(SORT,ORTABS(IMMUNIZATIONSTAB,1)_$$TABDESC^ORACCESS(IMMUNIZATIONSTAB,1))=0
End DoDot:2
End DoDot:1
+80 ;
+81 IF GETNOTES>0
Begin DoDot:1
+82 NEW MSG
SET SHOWEXCLUDE=0
+83 IF GETNOTES=2
IF RESULTS(CPRS,ORTABS(ORDERSTAB,3),WRITE)=1
Begin DoDot:2
+84 SET MSG=ORTABS(ORDERSTAB,1)_$$TABDESC^ORACCESS(ORDERSTAB,1)_", delayed orders "
+85 IF RESULTS(CPRS,ORTABS(DELAYEDORDERSTAB,3),WRITE)=0
SET MSG=MSG_"not "
+86 SET MSG=MSG_"allowed"
SET NOTES(SORT,MSG)=1
End DoDot:2
+87 SET (NCNT,LASTPARAM)=0
FOR PARAM=1:1:4
SET COUNT(PARAM)=0
+88 SET NODE=""
FOR
SET NODE=$ORDER(NOTES(SORT,NODE))
if NODE=""
QUIT
Begin DoDot:2
+89 SET PARAM=+$EXTRACT(NODE,1,1)
IF +NOTES(SORT,NODE)
SET COUNT(PARAM)=COUNT(PARAM)+1
End DoDot:2
+90 SET NODE=""
FOR
SET NODE=$ORDER(NOTES(SORT,NODE))
if NODE=""
QUIT
Begin DoDot:2
+91 SET PARAM=+$EXTRACT(NODE,1,1)
+92 IF PARAM'=LASTPARAM
Begin DoDot:3
+93 NEW IDX,MSGOUT
SET MSG=""
+94 SET LASTPARAM=PARAM
+95 IF NCNT>0
SET NCNT=NCNT+1
SET NOTES(NCNT)=""
+96 IF COUNT(PARAM)=0
Begin DoDot:4
+97 IF PARAM<3
Begin DoDot:5
+98 NEW MSGSORT,CNT,MAX
SET (IDX,CNT,MAX)=0
+99 FOR
SET IDX=$ORDER(ORTABS(IDX))
if 'IDX
QUIT
IF IDX'=DELAYEDORDERSTAB
IF ORTABS(IDX,1)=PARAM
SET MAX=MAX+1
+100 SET IDX=0
FOR
SET IDX=$ORDER(ORTABS(IDX))
if 'IDX
QUIT
IF IDX'=DELAYEDORDERSTAB
IF ORTABS(IDX,1)=PARAM
Begin DoDot:6
+101 SET MSGSORT($$TABDESC^ORACCESS(IDX,$SELECT(ORTABS(IDX,5)=2:1,1:0)))=""
End DoDot:6
+102 SET IDX=""
FOR
SET IDX=$ORDER(MSGSORT(IDX))
if IDX=""
QUIT
Begin DoDot:6
+103 SET CNT=CNT+1
IF MSG'=""
SET MSG=MSG_$SELECT(CNT<MAX:", ",1:" or ")
+104 SET MSG=MSG_IDX
End DoDot:6
+105 IF PARAM=1
SET MSG=MSG_" tabs"
End DoDot:5
+106 IF PARAM=3
SET MSG="any display groups"
+107 SET MSG="No write access for "_MSG_"."
+108 DO WRAP^ORUTL(MSG,"MSGOUT",1,0,3,0,78)
+109 SET IDX=0
FOR
SET IDX=$ORDER(MSGOUT(IDX))
if 'IDX
QUIT
Begin DoDot:5
+110 SET NCNT=NCNT+1
SET NOTES(NCNT)=MSGOUT(IDX)
End DoDot:5
End DoDot:4
IF 1
+111 ; COUNT(PARAM)>0
IF '$TEST
Begin DoDot:4
+112 SET NCNT=NCNT+1
+113 IF PARAM=1
SET NOTES(NCNT)="Write access allowed for the following tab"_$SELECT(COUNT(PARAM)>1:"s",1:"")_":"
+114 IF PARAM=2
SET NOTES(NCNT)="Write access allowed for the following additional functionality:"
+115 IF PARAM=3
Begin DoDot:5
+116 SET SHOWEXCLUDE=(COUNT(PARAM)<MAXGROUPS)&(COUNT(PARAM)>(MAXGROUPS/2))
+117 IF COUNT(PARAM)<MAXGROUPS
Begin DoDot:6
+118 IF SHOWEXCLUDE
SET NOTES(NCNT)="Ordering write access allowed for all display groups EXCEPT:"
+119 IF '$TEST
SET NOTES(NCNT)="Ordering write access allowed for the following display group"_$SELECT(COUNT(PARAM)>1:"s",1:"")_":"
End DoDot:6
+120 IF '$TEST
SET NOTES(NCNT)="Ordering write access allowed for all display groups."
End DoDot:5
+121 IF PARAM=4
SET NOTES(NCNT)="Missing write access dependenc"_$SELECT(COUNT(PARAM)=1:"y",1:"ies")_":"
End DoDot:4
End DoDot:3
+122 SET SHOW=(NOTES(SORT,NODE)>0)
IF PARAM=3
IF SHOWEXCLUDE
SET SHOW='SHOW
+123 IF SHOW
IF (PARAM'=3)!(COUNT(PARAM)<MAXGROUPS)
Begin DoDot:3
+124 SET NCNT=NCNT+1
SET NOTES(NCNT)=" "_$EXTRACT(NODE,2,999)
End DoDot:3
End DoDot:2
+125 KILL NOTES(SORT)
End DoDot:1
+126 QUIT
+127 ;
ADDGROUPRESULTS ;
+1 SET RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"ien")=IEN
+2 SET RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"name")=$PIECE(NODE,U)
+3 SET RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,"shortName")=$PIECE(NODE,U,3)
+4 SET RESULTS(CPRS,ORTABS(ORDERSTAB,3),DG,CNT,WRITE)=VALUE
+5 QUIT
+6 ;
VALUEMSG(ENT,INST,X,GETALL,MESSAGE,NAME) ;
+1 IF +$GET(NODEPENDENCIES)
QUIT
+2 SET GETALL=+$GET(GETALL)
+3 IF $GET(ENT)=""
QUIT
+4 IF 'GETALL
IF $GET(X)'="YES"
QUIT
+5 IF $PIECE($GET(DIR(0)),U,3)'=""
QUIT
+6 NEW CODE
+7 SET CODE=$PIECE($GET(INST),U)
+8 IF 'GETALL
IF "^A^D^I^"'[(U_CODE_U)
QUIT
+9 NEW ORPARAM,ORPIEN,ORTABS,TABS,OTHER,ORDERS,ERROR,IEN,MCNT
+10 NEW ORDERSTAB,ALLERGIESTAB,NOTESTAB,DELAYEDORDERSTAB,IMMUNIZATIONSTAB,ENCOUNTERSTAB
+11 DO GETPARAMS^ORACCESS(1)
+12 SET MCNT=0
+13 SET ORDERSTAB=$$TABIDX^ORACCESS(TABS,"O")
SET ALLERGIESTAB=$$TABIDX^ORACCESS(OTHER,"A")
+14 SET NOTESTAB=$$TABIDX^ORACCESS(TABS,"N")
SET DELAYEDORDERSTAB=$$TABIDX^ORACCESS(OTHER,"D")
+15 SET IMMUNIZATIONSTAB=$$TABIDX^ORACCESS(OTHER,"I")
SET ENCOUNTERSTAB=$$TABIDX^ORACCESS(OTHER,"E")
+16 IF GETALL
SET CODE=$SELECT(+$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(ALLERGIESTAB,1)),ENT,ORTABS(ALLERGIESTAB,2))):"A",1:"")
+17 IF CODE="A"
Begin DoDot:1
+18 NEW MSG
+19 IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(NOTESTAB,1)),ENT,ORTABS(NOTESTAB,2)))=0
Begin DoDot:2
+20 SET MSG=ORTABS(NOTESTAB,4)_" tab"
End DoDot:2
+21 IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(ORDERSTAB,1)),ENT,ORTABS(ORDERSTAB,2)))=0
Begin DoDot:2
+22 IF $DATA(MSG)
SET MSG=MSG_" and "
+23 SET MSG=$GET(MSG)_ORTABS(ORDERSTAB,4)_" tab"
End DoDot:2
IF 1
+24 IF '$TEST
Begin DoDot:2
+25 SET IEN=$ORDER(^ORD(100.98,"B","ALLERGIES",0))
+26 IF IEN
IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORDERS),ENT,IEN))=0
Begin DoDot:3
+27 IF $DATA(MSG)
SET MSG=MSG_" and "
+28 SET MSG=$GET(MSG)_"ALLERGIES display group"
End DoDot:3
End DoDot:2
+29 IF $DATA(MSG)
Begin DoDot:2
+30 SET MCNT=MCNT+1
SET MESSAGE(MCNT)=" "_ORTABS(ALLERGIESTAB,4)_" also requires "_MSG_" access."
End DoDot:2
End DoDot:1
+31 IF GETALL
SET CODE=$SELECT(+$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(DELAYEDORDERSTAB,1)),ENT,ORTABS(DELAYEDORDERSTAB,2))):"D",1:"")
+32 IF CODE="D"
Begin DoDot:1
+33 IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(ORDERSTAB,1)),ENT,ORTABS(ORDERSTAB,2)))=0
Begin DoDot:2
+34 SET MCNT=MCNT+1
SET MESSAGE(MCNT)=" "_ORTABS(DELAYEDORDERSTAB,4)_" also requires "_ORTABS(ORDERSTAB,4)_" tab access."
End DoDot:2
End DoDot:1
+35 IF GETALL
SET CODE=$SELECT(+$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(IMMUNIZATIONSTAB,1)),ENT,ORTABS(IMMUNIZATIONSTAB,2))):"I",1:"")
+36 IF CODE="I"
Begin DoDot:1
+37 NEW MSG
+38 IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(NOTESTAB,1)),ENT,ORTABS(NOTESTAB,2)))=0
Begin DoDot:2
+39 SET MSG=ORTABS(NOTESTAB,4)_" tab"
End DoDot:2
+40 IF +$GET(^XTV(8989.5,"AC",ORPIEN(ORTABS(ENCOUNTERSTAB,1)),ENT,ORTABS(ENCOUNTERSTAB,2)))=0
Begin DoDot:2
+41 IF $DATA(MSG)
SET MSG=MSG_" and "
+42 SET MSG=$GET(MSG)_ORTABS(ENCOUNTERSTAB,4)
End DoDot:2
+43 IF $DATA(MSG)
Begin DoDot:2
+44 SET MCNT=MCNT+1
SET MESSAGE(MCNT)=" "_ORTABS(IMMUNIZATIONSTAB,4)_" also requires "_MSG_" access."
End DoDot:2
End DoDot:1
+45 IF MCNT>0
Begin DoDot:1
+46 IF GETALL
Begin DoDot:2
+47 SET MESSAGE(0.5)="Missing write access dependenc"_$SELECT(MCNT=1:"y",1:"ies")_"* for "_$GET(NAME)
+48 SET MESSAGE(999)="* Dependencies may be resolved at a different level."
End DoDot:2
+49 IF 'GETALL
SET IEN=0
FOR
SET IEN=$ORDER(MESSAGE(IEN))
if 'IEN
QUIT
WRITE !,MESSAGE(IEN)
End DoDot:1
+50 QUIT
+51 ;
DLGOIINFO(ORY,LIST,INFO) ; Return orderable item info tied to each order dialog in the list
+1 ; INFO=1 Get LAB SECTION
+2 IF '+$GET(INFO)
QUIT
+3 NEW IDX,DLG,OI,OIIDX,SUBIDX,CODE,LINE
+4 SET OIIDX=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
IF 'OIIDX
QUIT
+5 SET (LINE,IDX)=0
FOR
SET IDX=$ORDER(LIST(IDX))
if 'IDX
QUIT
Begin DoDot:1
+6 SET (OI,SUBIDX)=0
FOR
SET SUBIDX=$ORDER(^ORD(101.41,LIST(IDX),6,SUBIDX))
if 'SUBIDX
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^ORD(101.41,LIST(IDX),6,SUBIDX,0)),U,2)=OIIDX
Begin DoDot:3
+8 SET OI=$PIECE($GET(^ORD(101.41,LIST(IDX),6,SUBIDX,1)),U,1)
End DoDot:3
QUIT
End DoDot:2
if OI
QUIT
+9 IF OI
Begin DoDot:2
+10 SET CODE=""
+11 IF INFO=1
SET CODE=$PIECE($GET(^ORD(101.43,OI,"LR")),U,6)
IF CODE=""
SET CODE="CH"
+12 IF CODE'=""
SET LINE=LINE+1
SET ORY(LINE)=LIST(IDX)_U_CODE
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
LABSBYXREF(ORY,DGSNAME) ; Return all LAB SECTION codes used by the specified XREF
+1 SET ORY=U
+2 NEW XREF
SET XREF="S."_DGSNAME
+3 IF "^S.LAB^S.AP^"'[(U_$GET(XREF)_U)
QUIT
+4 NEW DG,I,CODE,NAME,TEMP,LST,ILST,LIST,OUTPUT,ISAP,QUIT,APDLGIEN,X,CURTM
+5 SET CURTM=$$NOW^XLFDT
SET ISAP=(XREF="S.AP")
+6 SET NAME=""
FOR
SET NAME=$ORDER(^ORD(101.43,XREF,NAME))
if NAME=""
QUIT
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,XREF,NAME,I))
if 'I
QUIT
Begin DoDot:2
+8 SET X=$GET(^ORD(101.43,XREF,NAME,I))
+9 IF +$PIECE(X,U,3)
IF $PIECE(X,U,3)<CURTM
QUIT
+10 IF $PIECE(X,U,5)
QUIT
+11 IF ISAP
Begin DoDot:3
+12 SET QUIT=1
+13 IF '$$OK4CPRS^ORWLRAP1(I)
QUIT
+14 SET APDLGIEN=+$ORDER(^ORD(101.45,"C",I,0))
IF 'APDLGIEN
QUIT
+15 IF +$PIECE($GET(^ORD(101.45,APDLGIEN,0)),U,6)
QUIT
+16 SET QUIT=0
End DoDot:3
if QUIT
QUIT
+17 SET CODE=$PIECE($GET(^ORD(101.43,I,"LR")),U,6)
+18 IF CODE=""
SET CODE="CH"
+19 IF '$DATA(TEMP(CODE))
SET TEMP(CODE)=""
End DoDot:2
End DoDot:1
+20 SET ILST=0
+21 ; Also get any codes used by quick orders
IF XREF="S.LAB"
DO SHORT^ORWDLR32
+22 IF $DATA(LST)
Begin DoDot:1
+23 SET I=0
FOR
SET I=$ORDER(LST(I))
if 'I
QUIT
SET LST(I)=$EXTRACT($PIECE(LST(I),U,1),3,999)
+24 DO DLGOIINFO(.LIST,.LST,1)
+25 SET I=0
FOR
SET I=$ORDER(LIST(I))
if 'I
QUIT
Begin DoDot:2
+26 SET CODE=$PIECE(LIST(I),U,2)
IF CODE'=""
SET TEMP(CODE)=""
End DoDot:2
End DoDot:1
+27 SET I=""
FOR
SET I=$ORDER(TEMP(I))
if I=""
QUIT
SET ORY=ORY_I_U
+28 QUIT
+29 ;
DIETINFO(ORY) ; Return Diet Order Dialog info used to write access
+1 NEW IDX,NAME,IDX,X0,DG,TYPE,CNT,LIST,FORMS,FCNT
+2 SET (CNT,FCNT)=0
+3 DO ADD2ORY("DIETETICS")
+4 SET NAME="FHW"
FOR
SET NAME=$ORDER(^ORD(101.41,"B",NAME))
if $EXTRACT(NAME,1,3)'="FHW"
QUIT
Begin DoDot:1
+5 SET IDX=0
FOR
SET IDX=$ORDER(^ORD(101.41,"B",NAME,IDX))
if 'IDX
QUIT
Begin DoDot:2
+6 SET X0=$GET(^ORD(101.41,IDX,0))
IF $PIECE(X0,U,4)'="D"
QUIT
+7 SET DG=$PIECE(X0,U,5)
IF '+DG
QUIT
+8 SET TYPE=""
DO FINDTYP^ORWDFH(.TYPE,DG)
IF $GET(TYPE)=""
QUIT
+9 SET FCNT=FCNT+1
SET FORMS(FCNT)=NAME_U_DG
+10 SET LIST(DG)=DG_U_TYPE_U_$PIECE($GET(^ORD(100.98,DG,0)),U,3)
End DoDot:2
End DoDot:1
+11 SET IDX=0
FOR
SET IDX=$ORDER(LIST(IDX))
if 'IDX
QUIT
DO ADD2ORY(LIST(IDX))
+12 ;D ADD2ORY("-----")
+13 ;S IDX=0 F S IDX=$O(FORMS(IDX)) Q:'IDX D ADD2ORY(FORMS(IDX))
+14 QUIT
+15 ;
ADD2ORY(TEXT) ;
+1 SET CNT=CNT+1
SET ORY(CNT)=TEXT
+2 QUIT
