ORHRPC ; SLC/AGP - Provider Lookup API ;Dec 18, 2025@09:25:23
;;3.0;ORDER ENTRY/RESULTS REPORTING;**508**;Dec 17, 1997;Build 39
;
; Reference to ^DIC(9.4 is supported by ICR #2058
; Reference to File ^VA in ICR #4329
; Reference to File ^VA in ICR #10060
;
Q
;
FORMATINPUT(INPUTS,PARAMS) ;
N DIR
S DIR=$G(INPUTS("direction"))
S PARAMS("TAG")=$S($G(INPUTS("lookupType"))'="":INPUTS("lookupType"),1:"providerLookup")
S PARAMS("DIR")=$S(DIR="":1,DIR="down":1,DIR="up":-1,DIR=1:1,DIR=-1:-1,1:1)
I PARAMS("DIR")=1,$G(INPUTS("startFrom"))'="" D
.S INPUTS("startFrom")=$$REPLACELASTCHAR(INPUTS("startFrom"))
.I INPUTS("startFrom")'="" S INPUTS("startFrom")=INPUTS("startFrom")_"~"
S PARAMS("FROM")=$G(INPUTS("startFrom")),PARAMS("FROMID")=+$G(INPUTS("startId"))
M PARAMS("parameters")=INPUTS("parameters")
Q
;
REPLACELASTCHAR(INPUT) ;
N LCHAR,LEN,RESULT
S INPUT=$$UP^XLFSTR(INPUT)
S RESULT=INPUT
S LEN=$L(INPUT)
I LEN=0 Q RESULT
S LCHAR=$E(INPUT,LEN)
I LEN=1&(LCHAR="A"!(LCHAR="a")) S RESULT="" Q RESULT
I LCHAR?1A S $E(RESULT,LEN)=$S(LCHAR="A":"Z",LCHAR="a":"z",1:$C($A(LCHAR)-1))
Q RESULT
;
LOOKUP(RESULTS,IJSON) ;
N ARRAY,DATA,ERROR,INPUTS,PARAMS
D DECODE^XLFJSON("IJSON","INPUTS","ERROR")
D FORMATINPUT(.INPUTS,.PARAMS)
S ARRAY("hasPrevious")="false",ARRAY("hasMore")="false"
I PARAMS("TAG")="actionLookup" S PARAMS("promptValue")="A" D INFOFIELDS(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="colorLookup" S PARAMS("promptValue")="C" D INFOFIELDS(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="dataLookup" S PARAMS("promptValue")="D" D INFOFIELDS(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="editorLookup" D INFOEDITOR(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="imageLookup" S PARAMS("promptValue")="I" D INFOFIELDS(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="locationLookup" S PARAMS("promptValue")="L" D INFOFIELDS(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="packageLookup" D PACKAGE(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="providerLookup" D PROV(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="nvaProviderLookup" D NVA(.ARRAY,.PARAMS) G LOOKUPX
I PARAMS("TAG")="similarProvider" D SIMPROV(.ARRAY,.PARAMS) G LOOKUPX
LOOKUPX ;
D ENCODE^XLFJSON("ARRAY","RESULTS","ERROR")
Q
;
INFOFIELDS(ARRAY,PARAMS) ;
N CNT,IEN,NAME,PROMPT
S PROMPT=PARAMS("promptValue"),CNT=0
S NAME="" F S NAME=$O(^ORI(101.73,"TYPENAME",PROMPT,NAME)) Q:NAME="" D
.S IEN=+$O(^ORI(101.73,"TYPENAME",PROMPT,NAME,"")) Q:IEN=0
.S CNT=CNT+1,ARRAY("data",CNT,"const")=IEN,ARRAY("data",CNT,"title")=NAME
Q
;
INFOEDITOR(ARRAY,PARAMS) ;
N ONEOF
D GETEDITORS^ORDD71(.ONEOF,"editor")
M ARRAY("data")=ONEOF("editor")
Q
;
INFOPLUGIN(ARRAY,PARAMS) ;
N ONEOF
D GETPLUGINS^ORDD71(.ONEOF,"plugin")
M ARRAY("data")=ONEOF("plugin")
Q
;
NVA(ARRAY,PARAMS) ;
N DATA,IDX,PARAM
S PARAM("FROM")=PARAMS("FROM"),PARAM("DIR")=PARAMS("DIR")
S PARAM("NVAP")=$S($G(PARAMS("parameters","buttonClick"))="true":1,1:0)
S PARAM("HELP")=0
D PERSON(.DATA,.PARAM)
S IDX=+$O(DATA("A"),-1)
M ARRAY("data")=DATA
D PLACE(.ARRAY,.DATA,.PARAM)
Q
;
PACKAGE(ARRAY,PARAMS) ;
N CNT,DIR,IEN,MAX,NAME,TMP
S CNT=0,DIR=PARAMS("DIR"),NAME=PARAMS("FROM"),MAX=44
F S NAME=$O(^DIC(9.4,"B",NAME),DIR) Q:NAME=""!(CNT>44) D
.I NAME["*" Q
.S IEN=0 F S IEN=$O(^DIC(9.4,"B",NAME,IEN)) Q:IEN'>0!(CNT>44) D
..S CNT=CNT+1,ARRAY("data",CNT,"const")=IEN
..S TMP=$TR(NAME,"""","")
..S ARRAY("data",CNT,"display")=NAME,ARRAY("data",CNT,"title")=NAME
Q
;
PROV(ARRAY,PARAMS) ;
N DATA,IDX,PARAM
S PARAM("FROM")=PARAMS("FROM"),PARAM("DIR")=PARAMS("DIR")
S PARAM("KEY")="PROVIDER"
S PARAM("HELP")=0
D PERSON(.DATA,.PARAM)
S IDX=+$O(DATA("A"),-1)
M ARRAY("data")=DATA
D PLACE(.ARRAY,.DATA,.PARAM)
Q
;
SIMPROV(ARRAY,PARAMS) ;
N DATA,PARAM
I PARAMS("FROMID")="" Q
S PARAM("FROM")=PARAMS("FROMID"),PARAM("DIR")=PARAMS("DIR")
S PARAM("SPN")=1
S PARAM("HELP")=0
D PERSON(.DATA,.PARAM)
M ARRAY("data")=DATA
Q
;
PERSON(ARRAY,PARAM) ;
N CNT,FIEN,LIEN,IDX,LIDX,LIST
D NEWPERSON^ORNEWPERS(.LIST,.PARAM)
S CNT=0,IDX=0
F S IDX=$O(LIST(IDX)) Q:IDX'>0 D
.S CNT=CNT+1,LIDX=CNT
.S ARRAY(CNT,"const")=$P(LIST(IDX),U)
.S ARRAY(CNT,"display")=$P(LIST(IDX),U,2)_$S($P($G(LIST(IDX)),U,3)'="":" "_$P($G(LIST(IDX)),U,3),1:"")
.S ARRAY(CNT,"title")=$P(LIST(IDX),U,2)
Q
;
PLACE(ARRAY,DATA,PARAMS) ;
N FOUND,I,IDX,INF,J,MAX,NAME,P,PARAMETERS,PRM,TAG,XEC
S TAG="USR"
S PARAMETERS=$P($T(PARAMETERS^ORNEWPERS),"; ",2)
F I=1:1:$L(PARAMETERS,U) S PRM=$P(PARAMETERS,U,I) N @(PRM) D
. S (@(PRM),P(PRM))=$G(PARAMS(PRM))
. S INF(I,PRM)=$S($D(PARAMS(PRM)):PARAMS(PRM),1:"")
F I=0:1 S J=$P($T(@TAG+I^ORNEWPERS),";;",2,3) Q:J="" S XEC(I)=J
I PARAMS("FROM")'="" D POSITION($G(DATA(1,"title")),-1,"hasPrevious",.ARRAY,.XEC,.P)
S IDX=$O(DATA("A"),-1) I IDX>0 D POSITION($G(DATA(IDX,"title")),-1,"hasMore",.ARRAY,.XEC,.P)
Q
;
POSITION(FROM,DIR,SUB,ARRAY,XEC,P) ;
N FOUND,IEN,NAME
S NAME=FROM,FOUND=0 F S NAME=$O(^VA(200,"AUSER",NAME),DIR) Q:NAME=""!(FOUND>0) D
.S IEN=0 F S IEN=$O(^VA(200,"AUSER",NAME,IEN)) Q:IEN'>0!(FOUND>0) D
..S P("IEN")=IEN,P("NODE0")=$G(^VA(200,IEN,0))
..I '$$EVALUATE^ORNEWPERS(.XEC,.P) Q
..S ARRAY(SUB)="true",FOUND=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORHRPC 5273 printed May 25, 2026@12:35:01 Page 2
ORHRPC ; SLC/AGP - Provider Lookup API ;Dec 18, 2025@09:25:23
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**508**;Dec 17, 1997;Build 39
+2 ;
+3 ; Reference to ^DIC(9.4 is supported by ICR #2058
+4 ; Reference to File ^VA in ICR #4329
+5 ; Reference to File ^VA in ICR #10060
+6 ;
+7 QUIT
+8 ;
FORMATINPUT(INPUTS,PARAMS) ;
+1 NEW DIR
+2 SET DIR=$GET(INPUTS("direction"))
+3 SET PARAMS("TAG")=$SELECT($GET(INPUTS("lookupType"))'="":INPUTS("lookupType"),1:"providerLookup")
+4 SET PARAMS("DIR")=$SELECT(DIR="":1,DIR="down":1,DIR="up":-1,DIR=1:1,DIR=-1:-1,1:1)
+5 IF PARAMS("DIR")=1
IF $GET(INPUTS("startFrom"))'=""
Begin DoDot:1
+6 SET INPUTS("startFrom")=$$REPLACELASTCHAR(INPUTS("startFrom"))
+7 IF INPUTS("startFrom")'=""
SET INPUTS("startFrom")=INPUTS("startFrom")_"~"
End DoDot:1
+8 SET PARAMS("FROM")=$GET(INPUTS("startFrom"))
SET PARAMS("FROMID")=+$GET(INPUTS("startId"))
+9 MERGE PARAMS("parameters")=INPUTS("parameters")
+10 QUIT
+11 ;
REPLACELASTCHAR(INPUT) ;
+1 NEW LCHAR,LEN,RESULT
+2 SET INPUT=$$UP^XLFSTR(INPUT)
+3 SET RESULT=INPUT
+4 SET LEN=$LENGTH(INPUT)
+5 IF LEN=0
QUIT RESULT
+6 SET LCHAR=$EXTRACT(INPUT,LEN)
+7 IF LEN=1&(LCHAR="A"!(LCHAR="a"))
SET RESULT=""
QUIT RESULT
+8 IF LCHAR?1A
SET $EXTRACT(RESULT,LEN)=$SELECT(LCHAR="A":"Z",LCHAR="a":"z",1:$CHAR($ASCII(LCHAR)-1))
+9 QUIT RESULT
+10 ;
LOOKUP(RESULTS,IJSON) ;
+1 NEW ARRAY,DATA,ERROR,INPUTS,PARAMS
+2 DO DECODE^XLFJSON("IJSON","INPUTS","ERROR")
+3 DO FORMATINPUT(.INPUTS,.PARAMS)
+4 SET ARRAY("hasPrevious")="false"
SET ARRAY("hasMore")="false"
+5 IF PARAMS("TAG")="actionLookup"
SET PARAMS("promptValue")="A"
DO INFOFIELDS(.ARRAY,.PARAMS)
GOTO LOOKUPX
+6 IF PARAMS("TAG")="colorLookup"
SET PARAMS("promptValue")="C"
DO INFOFIELDS(.ARRAY,.PARAMS)
GOTO LOOKUPX
+7 IF PARAMS("TAG")="dataLookup"
SET PARAMS("promptValue")="D"
DO INFOFIELDS(.ARRAY,.PARAMS)
GOTO LOOKUPX
+8 IF PARAMS("TAG")="editorLookup"
DO INFOEDITOR(.ARRAY,.PARAMS)
GOTO LOOKUPX
+9 IF PARAMS("TAG")="imageLookup"
SET PARAMS("promptValue")="I"
DO INFOFIELDS(.ARRAY,.PARAMS)
GOTO LOOKUPX
+10 IF PARAMS("TAG")="locationLookup"
SET PARAMS("promptValue")="L"
DO INFOFIELDS(.ARRAY,.PARAMS)
GOTO LOOKUPX
+11 IF PARAMS("TAG")="packageLookup"
DO PACKAGE(.ARRAY,.PARAMS)
GOTO LOOKUPX
+12 IF PARAMS("TAG")="providerLookup"
DO PROV(.ARRAY,.PARAMS)
GOTO LOOKUPX
+13 IF PARAMS("TAG")="nvaProviderLookup"
DO NVA(.ARRAY,.PARAMS)
GOTO LOOKUPX
+14 IF PARAMS("TAG")="similarProvider"
DO SIMPROV(.ARRAY,.PARAMS)
GOTO LOOKUPX
LOOKUPX ;
+1 DO ENCODE^XLFJSON("ARRAY","RESULTS","ERROR")
+2 QUIT
+3 ;
INFOFIELDS(ARRAY,PARAMS) ;
+1 NEW CNT,IEN,NAME,PROMPT
+2 SET PROMPT=PARAMS("promptValue")
SET CNT=0
+3 SET NAME=""
FOR
SET NAME=$ORDER(^ORI(101.73,"TYPENAME",PROMPT,NAME))
if NAME=""
QUIT
Begin DoDot:1
+4 SET IEN=+$ORDER(^ORI(101.73,"TYPENAME",PROMPT,NAME,""))
if IEN=0
QUIT
+5 SET CNT=CNT+1
SET ARRAY("data",CNT,"const")=IEN
SET ARRAY("data",CNT,"title")=NAME
End DoDot:1
+6 QUIT
+7 ;
INFOEDITOR(ARRAY,PARAMS) ;
+1 NEW ONEOF
+2 DO GETEDITORS^ORDD71(.ONEOF,"editor")
+3 MERGE ARRAY("data")=ONEOF("editor")
+4 QUIT
+5 ;
INFOPLUGIN(ARRAY,PARAMS) ;
+1 NEW ONEOF
+2 DO GETPLUGINS^ORDD71(.ONEOF,"plugin")
+3 MERGE ARRAY("data")=ONEOF("plugin")
+4 QUIT
+5 ;
NVA(ARRAY,PARAMS) ;
+1 NEW DATA,IDX,PARAM
+2 SET PARAM("FROM")=PARAMS("FROM")
SET PARAM("DIR")=PARAMS("DIR")
+3 SET PARAM("NVAP")=$SELECT($GET(PARAMS("parameters","buttonClick"))="true":1,1:0)
+4 SET PARAM("HELP")=0
+5 DO PERSON(.DATA,.PARAM)
+6 SET IDX=+$ORDER(DATA("A"),-1)
+7 MERGE ARRAY("data")=DATA
+8 DO PLACE(.ARRAY,.DATA,.PARAM)
+9 QUIT
+10 ;
PACKAGE(ARRAY,PARAMS) ;
+1 NEW CNT,DIR,IEN,MAX,NAME,TMP
+2 SET CNT=0
SET DIR=PARAMS("DIR")
SET NAME=PARAMS("FROM")
SET MAX=44
+3 FOR
SET NAME=$ORDER(^DIC(9.4,"B",NAME),DIR)
if NAME=""!(CNT>44)
QUIT
Begin DoDot:1
+4 IF NAME["*"
QUIT
+5 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(9.4,"B",NAME,IEN))
if IEN'>0!(CNT>44)
QUIT
Begin DoDot:2
+6 SET CNT=CNT+1
SET ARRAY("data",CNT,"const")=IEN
+7 SET TMP=$TRANSLATE(NAME,"""","")
+8 SET ARRAY("data",CNT,"display")=NAME
SET ARRAY("data",CNT,"title")=NAME
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
PROV(ARRAY,PARAMS) ;
+1 NEW DATA,IDX,PARAM
+2 SET PARAM("FROM")=PARAMS("FROM")
SET PARAM("DIR")=PARAMS("DIR")
+3 SET PARAM("KEY")="PROVIDER"
+4 SET PARAM("HELP")=0
+5 DO PERSON(.DATA,.PARAM)
+6 SET IDX=+$ORDER(DATA("A"),-1)
+7 MERGE ARRAY("data")=DATA
+8 DO PLACE(.ARRAY,.DATA,.PARAM)
+9 QUIT
+10 ;
SIMPROV(ARRAY,PARAMS) ;
+1 NEW DATA,PARAM
+2 IF PARAMS("FROMID")=""
QUIT
+3 SET PARAM("FROM")=PARAMS("FROMID")
SET PARAM("DIR")=PARAMS("DIR")
+4 SET PARAM("SPN")=1
+5 SET PARAM("HELP")=0
+6 DO PERSON(.DATA,.PARAM)
+7 MERGE ARRAY("data")=DATA
+8 QUIT
+9 ;
PERSON(ARRAY,PARAM) ;
+1 NEW CNT,FIEN,LIEN,IDX,LIDX,LIST
+2 DO NEWPERSON^ORNEWPERS(.LIST,.PARAM)
+3 SET CNT=0
SET IDX=0
+4 FOR
SET IDX=$ORDER(LIST(IDX))
if IDX'>0
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
SET LIDX=CNT
+6 SET ARRAY(CNT,"const")=$PIECE(LIST(IDX),U)
+7 SET ARRAY(CNT,"display")=$PIECE(LIST(IDX),U,2)_$SELECT($PIECE($GET(LIST(IDX)),U,3)'="":" "_$PIECE($GET(LIST(IDX)),U,3),1:"")
+8 SET ARRAY(CNT,"title")=$PIECE(LIST(IDX),U,2)
End DoDot:1
+9 QUIT
+10 ;
PLACE(ARRAY,DATA,PARAMS) ;
+1 NEW FOUND,I,IDX,INF,J,MAX,NAME,P,PARAMETERS,PRM,TAG,XEC
+2 SET TAG="USR"
+3 SET PARAMETERS=$PIECE($TEXT(PARAMETERS^ORNEWPERS),"; ",2)
+4 FOR I=1:1:$LENGTH(PARAMETERS,U)
SET PRM=$PIECE(PARAMETERS,U,I)
NEW @(PRM)
Begin DoDot:1
+5 SET (@(PRM),P(PRM))=$GET(PARAMS(PRM))
+6 SET INF(I,PRM)=$SELECT($DATA(PARAMS(PRM)):PARAMS(PRM),1:"")
End DoDot:1
+7 FOR I=0:1
SET J=$PIECE($TEXT(@TAG+I^ORNEWPERS),";;",2,3)
if J=""
QUIT
SET XEC(I)=J
+8 IF PARAMS("FROM")'=""
DO POSITION($GET(DATA(1,"title")),-1,"hasPrevious",.ARRAY,.XEC,.P)
+9 SET IDX=$ORDER(DATA("A"),-1)
IF IDX>0
DO POSITION($GET(DATA(IDX,"title")),-1,"hasMore",.ARRAY,.XEC,.P)
+10 QUIT
+11 ;
POSITION(FROM,DIR,SUB,ARRAY,XEC,P) ;
+1 NEW FOUND,IEN,NAME
+2 SET NAME=FROM
SET FOUND=0
FOR
SET NAME=$ORDER(^VA(200,"AUSER",NAME),DIR)
if NAME=""!(FOUND>0)
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^VA(200,"AUSER",NAME,IEN))
if IEN'>0!(FOUND>0)
QUIT
Begin DoDot:2
+4 SET P("IEN")=IEN
SET P("NODE0")=$GET(^VA(200,IEN,0))
+5 IF '$$EVALUATE^ORNEWPERS(.XEC,.P)
QUIT
+6 SET ARRAY(SUB)="true"
SET FOUND=1
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
