ORWPCE5 ;SLC/JM - Wrap calls to PCE and Lexicon ;Jul 14, 2021@12:19:12
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
Q
;
UCUMLIST(Y,FROM,DIR) ; Long List for UCUM lookup - IA #6224
; .Y=returned list, FROM=text to $O from, DIR=$O direction
N I,DA,CNT,TIUD0,N0,N1
S I=0,CNT=80,DIR=$G(DIR,1)
F Q:I'<CNT S FROM=$O(^LEX(757.5,"UPB",FROM),DIR) Q:FROM="" D
. S DA=0
. F Q:I'<CNT S DA=$O(^LEX(757.5,"UPB",FROM,DA)) Q:+DA'>0 D
. . S N0=$G(^LEX(757.5,DA,0)) S N1=$G(^LEX(757.5,DA,1))
. . S I=I+1,Y(I)=DA_U_N0_U_$P(N1,U,1)
Q
;
REMTAX(Y) ; Returns a list of reminder taxonomies with standard codes
N TAXLIST,IDX,IEN,CODES,I
D TAXLIST^PXRMTAXI(.TAXLIST)
S IDX="",I=0
F S IDX=$O(TAXLIST(IDX)) Q:IDX="" D
. S IEN=TAXLIST(IDX)
. K CODES D CODELIST^PXRMTAXI(IEN,1,.CODES)
. I $O(CODES("SCT",""))'="" S I=I+1,Y(I)=IEN_U_IDX
Q
;
REPLCODE(RESULT,ENCDATE,CODESYS,CODE) ;
N CNT,CODELIST,TEMP
D UIDSEARCH^PXRMTXCS(CODESYS,CODE,ENCDATE,.CODELIST)
S TEMP="",CNT=0 F S TEMP=$O(CODELIST(TEMP)) Q:TEMP="" D
.I TEMP=CODE Q
.S CNT=CNT+1,RESULT(CNT)=TEMP_CODELIST(TEMP)
Q
;
TAXCODES(Y,TAXONOMY,DATE) ; Returns a list of standard codes within a taxonomy
N CODE,CODES,SYSTEM,SYSIEN,INFO,DESC
I $D(DATE)=0 S DATE=DT
D CODELIST^PXRMTAXI(TAXONOMY,1,.CODES)
S SYSTEM="SCT"
S SYSIEN=$P($$CSYS^LEXU(SYSTEM),U,1)
S CODE=0 F S CODE=$O(CODES(SYSTEM,CODE)) Q:CODE="" D
. S INFO=$$EXP^LEXCODE(CODE,SYSIEN,DATE) Q:+INFO<0
. S DESC=$P($G(INFO),U,2)
. I DESC'="" S Y(DESC)=SYSTEM_U_CODE_U_DESC
Q
;
NOTEDATE(Y,NOTEIEN) ; Returns note reference date for use as secondary visit date
D NOTEINFO(.Y,NOTEIEN,13,1)
Q
NOTELOC(Y,NOTEIEN) ; Returns the note location
D NOTEINFO(.Y,NOTEIEN,12,5)
Q
NOTEINFO(Y,NOTEIEN,NODE,PIECE) ; Returns note data
N IEN
I $$ISADDNDM^TIULC1(NOTEIEN) S IEN=$P($G(^TIU(8925,NOTEIEN,0)),U,6)
E S IEN=NOTEIEN
S Y=$P($G(^TIU(8925,IEN,NODE)),U,PIECE)
Q
;
MAGDAT(ORY,TYPE,CODE) ; Get Magnitute and UCUM code settings for a specific code
N FILE,IDX,IEN,N1,MAGCOMPLETE,PIECES
S ORY=""
S FILE=$S(TYPE="PED":9999999.09,TYPE="XAM":9999999.15,TYPE="HF":9999999.64,TYPE="SC":811.2,1:0) I 'FILE Q
S ORY=$S(FILE=811.2:$$GMPARAMS^PXRMDTAX(CODE),1:$$GMPARAMS^PXAPI(FILE,CODE))
S MAGCOMPLETE=1
S PIECES=$L(ORY,U)
F IDX=1:1:PIECES I $P(ORY,U,IDX)="" S MAGCOMPLETE=0
I 'MAGCOMPLETE S ORY="" Q
S IEN=$P(ORY,U,4) I IEN D
. S ORY=ORY_U_$G(^LEX(757.5,IEN,0))
. S N1=$S($P(ORY,U,6)="C":$P($G(^LEX(757.5,IEN,1)),U,1),$P(ORY,U,6)="N":"",1:$P($G(^LEX(757.5,IEN,0)),U))
. ;I "^(^{^[^"'[(U_$E(N1)_U) S N1="("_N1_")"
. ;I N1'="" S $P(ORY,U,6)=N1
. S $P(ORY,U,6)=N1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWPCE5 2689 printed Sep 23, 2025@20:13:21 Page 2
ORWPCE5 ;SLC/JM - Wrap calls to PCE and Lexicon ;Jul 14, 2021@12:19:12
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
+2 QUIT
+3 ;
UCUMLIST(Y,FROM,DIR) ; Long List for UCUM lookup - IA #6224
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction
+2 NEW I,DA,CNT,TIUD0,N0,N1
+3 SET I=0
SET CNT=80
SET DIR=$GET(DIR,1)
+4 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^LEX(757.5,"UPB",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
if I'<CNT
QUIT
SET DA=$ORDER(^LEX(757.5,"UPB",FROM,DA))
if +DA'>0
QUIT
Begin DoDot:2
+7 SET N0=$GET(^LEX(757.5,DA,0))
SET N1=$GET(^LEX(757.5,DA,1))
+8 SET I=I+1
SET Y(I)=DA_U_N0_U_$PIECE(N1,U,1)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
REMTAX(Y) ; Returns a list of reminder taxonomies with standard codes
+1 NEW TAXLIST,IDX,IEN,CODES,I
+2 DO TAXLIST^PXRMTAXI(.TAXLIST)
+3 SET IDX=""
SET I=0
+4 FOR
SET IDX=$ORDER(TAXLIST(IDX))
if IDX=""
QUIT
Begin DoDot:1
+5 SET IEN=TAXLIST(IDX)
+6 KILL CODES
DO CODELIST^PXRMTAXI(IEN,1,.CODES)
+7 IF $ORDER(CODES("SCT",""))'=""
SET I=I+1
SET Y(I)=IEN_U_IDX
End DoDot:1
+8 QUIT
+9 ;
REPLCODE(RESULT,ENCDATE,CODESYS,CODE) ;
+1 NEW CNT,CODELIST,TEMP
+2 DO UIDSEARCH^PXRMTXCS(CODESYS,CODE,ENCDATE,.CODELIST)
+3 SET TEMP=""
SET CNT=0
FOR
SET TEMP=$ORDER(CODELIST(TEMP))
if TEMP=""
QUIT
Begin DoDot:1
+4 IF TEMP=CODE
QUIT
+5 SET CNT=CNT+1
SET RESULT(CNT)=TEMP_CODELIST(TEMP)
End DoDot:1
+6 QUIT
+7 ;
TAXCODES(Y,TAXONOMY,DATE) ; Returns a list of standard codes within a taxonomy
+1 NEW CODE,CODES,SYSTEM,SYSIEN,INFO,DESC
+2 IF $DATA(DATE)=0
SET DATE=DT
+3 DO CODELIST^PXRMTAXI(TAXONOMY,1,.CODES)
+4 SET SYSTEM="SCT"
+5 SET SYSIEN=$PIECE($$CSYS^LEXU(SYSTEM),U,1)
+6 SET CODE=0
FOR
SET CODE=$ORDER(CODES(SYSTEM,CODE))
if CODE=""
QUIT
Begin DoDot:1
+7 SET INFO=$$EXP^LEXCODE(CODE,SYSIEN,DATE)
if +INFO<0
QUIT
+8 SET DESC=$PIECE($GET(INFO),U,2)
+9 IF DESC'=""
SET Y(DESC)=SYSTEM_U_CODE_U_DESC
End DoDot:1
+10 QUIT
+11 ;
NOTEDATE(Y,NOTEIEN) ; Returns note reference date for use as secondary visit date
+1 DO NOTEINFO(.Y,NOTEIEN,13,1)
+2 QUIT
NOTELOC(Y,NOTEIEN) ; Returns the note location
+1 DO NOTEINFO(.Y,NOTEIEN,12,5)
+2 QUIT
NOTEINFO(Y,NOTEIEN,NODE,PIECE) ; Returns note data
+1 NEW IEN
+2 IF $$ISADDNDM^TIULC1(NOTEIEN)
SET IEN=$PIECE($GET(^TIU(8925,NOTEIEN,0)),U,6)
+3 IF '$TEST
SET IEN=NOTEIEN
+4 SET Y=$PIECE($GET(^TIU(8925,IEN,NODE)),U,PIECE)
+5 QUIT
+6 ;
MAGDAT(ORY,TYPE,CODE) ; Get Magnitute and UCUM code settings for a specific code
+1 NEW FILE,IDX,IEN,N1,MAGCOMPLETE,PIECES
+2 SET ORY=""
+3 SET FILE=$SELECT(TYPE="PED":9999999.09,TYPE="XAM":9999999.15,TYPE="HF":9999999.64,TYPE="SC":811.2,1:0)
IF 'FILE
QUIT
+4 SET ORY=$SELECT(FILE=811.2:$$GMPARAMS^PXRMDTAX(CODE),1:$$GMPARAMS^PXAPI(FILE,CODE))
+5 SET MAGCOMPLETE=1
+6 SET PIECES=$LENGTH(ORY,U)
+7 FOR IDX=1:1:PIECES
IF $PIECE(ORY,U,IDX)=""
SET MAGCOMPLETE=0
+8 IF 'MAGCOMPLETE
SET ORY=""
QUIT
+9 SET IEN=$PIECE(ORY,U,4)
IF IEN
Begin DoDot:1
+10 SET ORY=ORY_U_$GET(^LEX(757.5,IEN,0))
+11 SET N1=$SELECT($PIECE(ORY,U,6)="C":$PIECE($GET(^LEX(757.5,IEN,1)),U,1),$PIECE(ORY,U,6)="N":"",1:$PIECE($GET(^LEX(757.5,IEN,0)),U))
+12 ;I "^(^{^[^"'[(U_$E(N1)_U) S N1="("_N1_")"
+13 ;I N1'="" S $P(ORY,U,6)=N1
+14 SET $PIECE(ORY,U,6)=N1
End DoDot:1
+15 QUIT
+16 ;
