Routine: ORWPCE5

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

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)

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

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)

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

NOTEDATE(Y,NOTEIEN) ; Returns note reference date for use as secondary visit date

 D NOTEINFO(.Y,NOTEIEN,13,1)

NOTELOC(Y,NOTEIEN) ; Returns the note location

 D NOTEINFO(.Y,NOTEIEN,12,5)

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWPCE5   2689     printed  Mar 13, 2025@21:42:02                                                                                                                                                                                                     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      ;

ORWPCE5.m