- ORACCES2 ;SLC/JNM - User Read/Write Access to CPRS ; Jan 05, 2024@12:47
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**588,608**;Dec 17, 1997;Build 15;
- ; 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 CNT,DIET,IEN,DG,TYPE,NAME
- S CNT=0
- D ADD2ORY("DIETETICS")
- S DIET=$O(^ORD(100.98,"B","DIETETICS",0)) Q:'DIET
- S IEN=0 F S IEN=$O(^ORD(100.98,DIET,1,IEN)) Q:'IEN D
- . S DG=$P($G(^ORD(100.98,DIET,1,IEN,0)),U) Q:'+DG
- . S TYPE="" D FINDTYP^ORWDFH(.TYPE,DG) I $G(TYPE)="" Q
- . S NAME=$P($G(^ORD(100.98,DG,0)),U,3) Q:NAME="D CON"
- . D ADD2ORY(DG_U_TYPE_U_$P($G(^ORD(100.98,DG,0)),U,3))
- Q
- ;
- ADD2ORY(TEXT) ;
- S CNT=CNT+1,ORY(CNT)=TEXT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORACCES2 11716 printed Jan 18, 2025@03:27:59 Page 2
- ORACCES2 ;SLC/JNM - User Read/Write Access to CPRS ; Jan 05, 2024@12:47
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**588,608**;Dec 17, 1997;Build 15;
- +2 ; Reference to ^XTV(8989.5,"AC" in ICR #2686
- +3 QUIT
- +4 ;
- 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 CNT,DIET,IEN,DG,TYPE,NAME
- +2 SET CNT=0
- +3 DO ADD2ORY("DIETETICS")
- +4 SET DIET=$ORDER(^ORD(100.98,"B","DIETETICS",0))
- if 'DIET
- QUIT
- +5 SET IEN=0
- FOR
- SET IEN=$ORDER(^ORD(100.98,DIET,1,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +6 SET DG=$PIECE($GET(^ORD(100.98,DIET,1,IEN,0)),U)
- if '+DG
- QUIT
- +7 SET TYPE=""
- DO FINDTYP^ORWDFH(.TYPE,DG)
- IF $GET(TYPE)=""
- QUIT
- +8 SET NAME=$PIECE($GET(^ORD(100.98,DG,0)),U,3)
- if NAME="D CON"
- QUIT
- +9 DO ADD2ORY(DG_U_TYPE_U_$PIECE($GET(^ORD(100.98,DG,0)),U,3))
- End DoDot:1
- +10 QUIT
- +11 ;
- ADD2ORY(TEXT) ;
- +1 SET CNT=CNT+1
- SET ORY(CNT)=TEXT
- +2 QUIT