PXRMVSCS ;SLC/PKR - Value set code search routines. ;11/21/2014
;;2.0;CLINICAL REMINDERS;**47**;Feb 04, 2005;Build 291
;==========================================
CODESRCH ;Search all value sets for a specified code.
N CODE,CSYSIEN,RESULT
D FULL^VALM1
S RESULT=$$GETCODE(.CSYSIEN,.CODE)
I 'RESULT Q
D CSEARCH(CSYSIEN,CODE)
S VALMBCK="R"
Q
;
;==========================================
CSEARCH(CSYSIEN,CODE) ;Find all value sets containing the specified code.
N IND,JND,NL,TEXT,VSIEN,VSL,VSOID,VSNAME,VSVDATE
S VSNAME=""
F S VSNAME=$O(^PXRM(802.2,"B",VSNAME)) Q:VSNAME="" D
. S VSIEN=0
. F S VSIEN=+$O(^PXRM(802.2,"B",VSNAME,VSIEN)) Q:VSIEN=0 D
.. I '$D(^PXRM(802.2,VSIEN,2,"B",CSYSIEN)) Q
.. S IND=$O(^PXRM(802.2,VSIEN,2,"B",CSYSIEN,""))
.. S JND=0
.. F S JND=+$O(^PXRM(802.2,VSIEN,2,IND,1,JND)) Q:JND=0 D
... I ^PXRM(802.2,VSIEN,2,IND,1,JND,0)=CODE S VSL(VSNAME,VSIEN)=""
;Build the output.
S TEXT(1)="Searching all value sets for the "_$P(^PXRM(802.1,CSYSIEN,0),U,1)_" code "_CODE
I $D(VSL) S TEXT(2)="It was found in the following value sets:"
E S TEXT(2)=" It was not found in any value set."
S VSNAME="",NL=2
F S VSNAME=$O(VSL(VSNAME)) Q:VSNAME="" D
. S VSIEN=0
. F S VSIEN=+$O(VSL(VSNAME,VSIEN)) Q:VSIEN=0 D
.. S VSOID=$P(^PXRM(802.2,VSIEN,1),U,1)
.. S VSVDATE=$P(^PXRM(802.2,VSIEN,1),U,3)
.. S NL=NL+1,TEXT(NL)=""
.. S NL=NL+1,TEXT(NL)=" "_VSNAME
.. S NL=NL+1,TEXT(NL)=" OID: "_VSOID
.. S NL=NL+1,TEXT(NL)=" Version date: "_$$FMTE^XLFDT(VSVDATE)
.. S NL=NL+1,TEXT(NL)=""
D BROWSE^DDBR("TEXT","NR","Value Set Code Search")
Q
;
;==========================================
GETCODE(CSYSIEN,CODE) ;Prompt the user for the code to search for.
N CSIEN,CSNAME,CSVER,DIC,DIR,X,Y
W !!,"NLM Value Set Coding Systems"
S CSNAME=""
F S CSNAME=$O(^PXRM(802.1,"B",CSNAME)) Q:CSNAME="" D
. S CSIEN=$O(^PXRM(802.1,"B",CSNAME,""))
. S CSVER=$P(^PXRM(802.1,CSIEN,0),U,3)
. W !," ",CSNAME," version ",CSVER
S DIC=802.1,DIC(0)="AE"
S DIC("A")="Select the coding system: "
D ^DIC
S CSYSIEN=$P(Y,U,1)
I CSYSIEN=-1 Q 0
S DIR(0)="FAU^3:64"
S DIR("A")="Input the code: "
D ^DIR
S CODE=Y
I CODE="^" Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMVSCS 2224 printed Dec 13, 2024@01:49:59 Page 2
PXRMVSCS ;SLC/PKR - Value set code search routines. ;11/21/2014
+1 ;;2.0;CLINICAL REMINDERS;**47**;Feb 04, 2005;Build 291
+2 ;==========================================
CODESRCH ;Search all value sets for a specified code.
+1 NEW CODE,CSYSIEN,RESULT
+2 DO FULL^VALM1
+3 SET RESULT=$$GETCODE(.CSYSIEN,.CODE)
+4 IF 'RESULT
QUIT
+5 DO CSEARCH(CSYSIEN,CODE)
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
+9 ;==========================================
CSEARCH(CSYSIEN,CODE) ;Find all value sets containing the specified code.
+1 NEW IND,JND,NL,TEXT,VSIEN,VSL,VSOID,VSNAME,VSVDATE
+2 SET VSNAME=""
+3 FOR
SET VSNAME=$ORDER(^PXRM(802.2,"B",VSNAME))
if VSNAME=""
QUIT
Begin DoDot:1
+4 SET VSIEN=0
+5 FOR
SET VSIEN=+$ORDER(^PXRM(802.2,"B",VSNAME,VSIEN))
if VSIEN=0
QUIT
Begin DoDot:2
+6 IF '$DATA(^PXRM(802.2,VSIEN,2,"B",CSYSIEN))
QUIT
+7 SET IND=$ORDER(^PXRM(802.2,VSIEN,2,"B",CSYSIEN,""))
+8 SET JND=0
+9 FOR
SET JND=+$ORDER(^PXRM(802.2,VSIEN,2,IND,1,JND))
if JND=0
QUIT
Begin DoDot:3
+10 IF ^PXRM(802.2,VSIEN,2,IND,1,JND,0)=CODE
SET VSL(VSNAME,VSIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;Build the output.
+12 SET TEXT(1)="Searching all value sets for the "_$PIECE(^PXRM(802.1,CSYSIEN,0),U,1)_" code "_CODE
+13 IF $DATA(VSL)
SET TEXT(2)="It was found in the following value sets:"
+14 IF '$TEST
SET TEXT(2)=" It was not found in any value set."
+15 SET VSNAME=""
SET NL=2
+16 FOR
SET VSNAME=$ORDER(VSL(VSNAME))
if VSNAME=""
QUIT
Begin DoDot:1
+17 SET VSIEN=0
+18 FOR
SET VSIEN=+$ORDER(VSL(VSNAME,VSIEN))
if VSIEN=0
QUIT
Begin DoDot:2
+19 SET VSOID=$PIECE(^PXRM(802.2,VSIEN,1),U,1)
+20 SET VSVDATE=$PIECE(^PXRM(802.2,VSIEN,1),U,3)
+21 SET NL=NL+1
SET TEXT(NL)=""
+22 SET NL=NL+1
SET TEXT(NL)=" "_VSNAME
+23 SET NL=NL+1
SET TEXT(NL)=" OID: "_VSOID
+24 SET NL=NL+1
SET TEXT(NL)=" Version date: "_$$FMTE^XLFDT(VSVDATE)
+25 SET NL=NL+1
SET TEXT(NL)=""
End DoDot:2
End DoDot:1
+26 DO BROWSE^DDBR("TEXT","NR","Value Set Code Search")
+27 QUIT
+28 ;
+29 ;==========================================
GETCODE(CSYSIEN,CODE) ;Prompt the user for the code to search for.
+1 NEW CSIEN,CSNAME,CSVER,DIC,DIR,X,Y
+2 WRITE !!,"NLM Value Set Coding Systems"
+3 SET CSNAME=""
+4 FOR
SET CSNAME=$ORDER(^PXRM(802.1,"B",CSNAME))
if CSNAME=""
QUIT
Begin DoDot:1
+5 SET CSIEN=$ORDER(^PXRM(802.1,"B",CSNAME,""))
+6 SET CSVER=$PIECE(^PXRM(802.1,CSIEN,0),U,3)
+7 WRITE !," ",CSNAME," version ",CSVER
End DoDot:1
+8 SET DIC=802.1
SET DIC(0)="AE"
+9 SET DIC("A")="Select the coding system: "
+10 DO ^DIC
+11 SET CSYSIEN=$PIECE(Y,U,1)
+12 IF CSYSIEN=-1
QUIT 0
+13 SET DIR(0)="FAU^3:64"
+14 SET DIR("A")="Input the code: "
+15 DO ^DIR
+16 SET CODE=Y
+17 IF CODE="^"
QUIT 0
+18 QUIT 1
+19 ;
