IBDFRPC2 ;ALB/AAS - Return list of selections, broker call ;29-JAN-96
;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
;
SEL(RESULT,IBDF) ; -- Procedure
; -- called by ibdfrpc1, returns list for one selection list
; see ibdfrpc1 for complete input/output lists
; -- Input IBDF("IEN") := pointer to selection list (357.2)
; IBDF("PI") := pointer to package interface (357.6) (optional)
; IBDF("DFN") := pointer to patient (2) (optional)
; IBDF("CLINIC") := pointer to clinic (44) (optional)
;
N OTEXT,TEXT,SC,TERM,COUNT,DCODE,SECOND,THIRD
I $E($G(RESULT),1)="^" S ARRY=RESULT
E S ARRY="RESULT"
S COUNT=+$G(@ARRY@(0))
;
S @ARRY@(0)="List not found"
G:'$G(IBDF("IEN")) SELQ
G:$G(^IBE(357.2,IBDF("IEN"),0))="" SELQ
;K ^TMP("IBD-DUP",$J)
;
; -- copy list
I '$G(IBDF("RULE-ONLY")) D COPYLIST(.RESULT,IBDF("IEN"),.COUNT)
;I COUNT D URH
;
S @ARRY@(0)=COUNT_"^LIST^"
D GETQLF
SELQ Q
;
GETQLF ; -- add selection rule and qualifiers from marking area
; subcolumns to results(0) node, but only for bubbles
N SC,NODE,BUBB,BUBBCNT
S SC=0,BUBBCNT=0,BUBB=$O(^IBE(357.91,"B","BUBBLE (use for scanning)",0)) Q:'BUBB
F S SC=$O(^IBE(357.2,IBDF("IEN"),2,SC)) Q:'SC D
.S NODE=$G(^IBE(357.2,IBDF("IEN"),2,SC,0))
.I $P(NODE,"^",4)=2,$P(NODE,"^",6)=BUBB S BUBBCNT=BUBBCNT+1,@ARRY@(0)=@ARRY@(0)_$P($G(^IBD(357.98,+$P(NODE,"^",9),0)),"^")_";;"_+$P(NODE,"^",10)_"::"
;
; -- if no bubbles then kill off array, leave zero node for reports
I BUBBCNT<1 S SC=@ARRY@(0) K @ARRY S @ARRY@(0)="0^"_$P(SC,"^",2,3) S $P(@ARRY@(0),"^",4)=1
Q
;
COPYLIST(RESULT,LIST,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
;
N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,GROUP,ORDER,HDR,CSUBCOL,DCODE,QUANTITY,SECOND,THIRD
;
I $E($G(RESULT),1)="^" S ARRY=RESULT
E S ARRY="RESULT"
;
S SUBCOL=$$SUBCOL(LIST),TSUBCOL=+SUBCOL,CSUBCOL=+$P(SUBCOL,"^",2)
;
S PRNT=""
F S PRNT=$O(^IBE(357.4,"APO",LIST,PRNT)) Q:PRNT="" D
. S GROUP=""
. F S GROUP=$O(^IBE(357.4,"APO",LIST,PRNT,GROUP)) Q:GROUP="" D
.. S HDR=$P($G(^IBE(357.4,GROUP,0)),"^")
.. I $P($G(^IBE(357.4,GROUP,0)),"^",4)="I" S HDR=" "
.. I HDR="BLANK" S HDR=" "
.. S COUNT=COUNT+1,@ARRY@(COUNT)=HDR_"^^^^^^0"
.. S ORDER=""
.. F S ORDER=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER)) Q:ORDER="" D
... S SLCTN=0
... F S SLCTN=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN)) Q:'SLCTN D
.... S (TEXT,DCODE,OTEXT,TERM,NOTREAL,IEN,SECOND,THIRD)=""
.... S NODE=$G(^IBE(357.3,SLCTN,0)),IEN=$P(NODE,"^")
.... S QUANTITY=$P(NODE,"^",9)
.... ;
.... ; -- handle place holder as headers
.... S NOTREAL=$P(NODE,"^",2)
.... I NOTREAL,$P(NODE,"^",6)'="" D Q
..... I $P(NODE,"^",7) S COUNT=COUNT+1,HDR=$P(NODE,"^",6),@ARRY@(COUNT)=HDR_"^^^^^^0" Q
..... I $P(NODE,"^",8) S COUNT=COUNT+1,HDR=" ",@ARRY@(COUNT)=HDR_"^^^^^^0" Q
.....;
.... ; -- find text for entry
.... S SUBCOL=$O(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0))
.... S NODE=$G(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
.... S:$P(NODE,"^")=TSUBCOL TEXT=$P(NODE,"^",2)
.... ;
.... ; -- find display code for entry
.... S SUBCOL=$O(^IBE(357.3,+SLCTN,1,"B",+CSUBCOL,0))
.... S NODE=$G(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
.... S:$P(NODE,"^")=CSUBCOL DCODE=$P(NODE,"^",2)
.... ;
.... ; -- find optional caption and lexicon pointer
.... S NODE=$G(^IBE(357.3,SLCTN,2))
.... S OTEXT=$P(NODE,"^"),TERM=$P(NODE,"^",2)
.... ;
.... ; -- find optional second and third codes
.... S SECOND=$P(NODE,"^",3),THIRD=$P(NODE,"^",4)
.... ;
.... ; -- add to array. Is dup ien or ien+text???
.... I $L(TEXT) S COUNT=COUNT+1 D BLDA Q
.... ;I $L(TEXT),'$D(IBDUP(IEN_"^"_TEXT)) S COUNT=COUNT+1,IBDUP(IEN_"^"_TEXT)="" D BLDA Q ;this line checks ien+text for duplicates
;
K ^TMP("IBD-DUP",$J)
Q
;
SUBCOL(LIST) ; -- function
; -- returns the subcolumn containing the text
; input LIST := selection list internal entry
; -- Assumes data returned by the package interface, piece 2 is the description
;
N SC,TSUBCOL,CSUBCOL
S (TSUBCOL,CSUBCOL)=""
S SC=0
F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC D
.Q:$P($G(^IBE(357.2,LIST,2,SC,0)),"^",4)=2 ;is a marking area
.I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=2 S TSUBCOL=$P(^(0),"^") Q ;data piece 2 is usually text subcol
.I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=1 S CSUBCOL=$P(^(0),"^") Q ; data piece 1 is always code
.I TSUBCOL="",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)>2 S TSUBCOL=$P(^(0),"^") Q ; -- see if other than data piece two is text subcolumn
.I CSUBCOL="",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)>2 S CSUBCOL=$P(^(0),"^") Q
Q TSUBCOL_"^"_CSUBCOL
;
BLDA ; -- build results array
S @ARRY@(COUNT)=TEXT ;B ;;
S $P(@ARRY@(COUNT),"^",2)=$G(DCODE)
S $P(@ARRY@(COUNT),"^",3)=$S($G(NOTREAL):"",1:$G(IEN))
S $P(@ARRY@(COUNT),"^",4)=""
S $P(@ARRY@(COUNT),"^",5)=$G(OTEXT)
S $P(@ARRY@(COUNT),"^",6)=$G(TERM)
S $P(@ARRY@(COUNT),"^",7)=$S($G(NOTREAL):0,1:1)
S $P(@ARRY@(COUNT),"^",9)=$G(QUANTITY)
S $P(@ARRY@(COUNT),"^",10)=$G(SECOND)
S $P(@ARRY@(COUNT),"^",11)=$G(THIRD)
;--added for slctn to be passed also
S $P(@ARRY@(COUNT),"^",12)=$G(SLCTN)
Q
;
URH ; -- UnReferenced Headers removal
; if a header doesn't have any data under it, then remove the header
N X,HDR
S X=0 F S X=$O(@ARRY@(X)) Q:'X D
.I '$D(HDR),$P(@ARRY@(X),"^",1)="" S HDR=X Q ;find a header
.I $P(@ARRY@(X),"^",1)="" K HDR Q ; is item under header
.I $D(HDR),$P(@ARRY@(X),"^",1)="" K @ARRY@(HDR) S COUNT=COUNT-1,HDR=X ;hdr doesn't have any items, kill hdr node and reset header to next header
I $D(HDR) S X=$O(@ARRY@(""),-1) I $P(@ARRY@(X),"^",1)="" K @ARRY@(X) S COUNT=COUNT-1,HDR=X ;last item in list is a header
Q
;
DYN(RESULT,IBDF) ; -- Procedure
; -- called by ibdfrpc1 to return selection list for dynamic selections
; see ibdfrpc1 for complete input/output lists
; -- Input IBDF("PI") := pointer to package interface (357.6)
; IBDF("IEN") := pointer to selection list (357.2)
; IBDF("DFN") := pointer to patient (2) (optional for provider selections)
; IBDF("CLINIC") := pointer to clinic (44) (optional for active problem selections)
;
N PI,DFN,CNT,COUNT,NAME,RTN,IBARY,IBCLINIC
I $E($G(RESULT),1)="^" S ARRY=RESULT
E S ARRY="RESULT"
S COUNT=+$G(@ARRY@(0))
I '$G(IBDF("DFN")) S @ARRY@(0)="-1^Patient not defined" G DYNQ
I $G(^DPT(+IBDF("DFN"),0))="" S @ARRY@(0)="-1^Patient not Found" G DYNQ
S DFN=+$G(IBDF("DFN"))
I $G(IBDF("RULE-ONLY")) G RULE
;
S @ARRY@(0)="List not found"
G:'$G(IBDF("IEN")) SELQ
G:$G(^IBE(357.2,IBDF("IEN"),0))="" DYNQ
;
S @ARRY@(0)="-1^Package Interface Not found"
S PI=$G(^IBE(357.6,+$G(IBDF("PI")),0)) I PI="" G DYNQ
;
S IBCLINIC=$G(IBDF("CLINIC"))
I +IBCLINIC'=IBCLINIC,IBCLINIC'="" S IBCLINIC=$O(^SC("B",IBCLINIC,0))
I +IBCLINIC=0 S @ARRY@(0)="Clinic Not Specified"
;
S NAME=$P(PI,"^"),RTN=$P(PI,"^",2,3) I RTN=""!(RTN="^") G DYNQ
I NAME["ACTIVE PROBLEM" S NAME="GMP SELECT PATIENT ACTIVE PROBLEMS"
S IBARY="^TMP(""IB"",$J,""INTERFACES"","""_NAME_""")"
D @RTN
;
S @ARRY@(0)=+$G(@IBARY@(0))_"^LIST^"
RULE I $G(IBDF("RULE-ONLY")) S @ARRY@(0)="1^DYNLIST^"
;G DYNQ:@ARRY@(0)<1
D GETQLF
G:$G(IBDF("RULE-ONLY")) DYNQ
;
S CNT=0 F S CNT=$O(@IBARY@(CNT)) Q:'CNT D
.Q:$G(@IBARY@(CNT))=""
.;
.; -- Process provider lists
.I NAME["PROVIDER" D Q
..I IBCLINIC<1 Q
..S @ARRY@(CNT)=$P(@IBARY@(CNT),"^",2)_"^^"_$P(@IBARY@(CNT),"^",1)_"^^^^1" Q
.;
.; -- process patient active problem lists
.I NAME["ACTIVE PROBLEMS" D Q
..S @ARRY@(CNT)=$P(@IBARY@(CNT),"^",2)_"^"_$P(@IBARY@(CNT),"^",3)_"^"_+@IBARY@(CNT)_"^^^^1"
.I '$D(@ARRY@(CNT)) S @ARRY@(CNT)=@IBARY@(CNT)
;
DYNQ Q
;
; -- here are some sample tests for different lists
TEST K VAR,IBDF
S IBDF("IEN")=489
D SEL(.VAR,.IBDF)
X "ZW VAR"
Q
;
TEST1 K VAR,IBDF
S IBDF("IEN")=488
D SEL(.VAR,.IBDF)
X "ZW VAR"
Q
;
TESTD ; -- Test dynamic
K VAR,IBDF
;S IBDF("PI")=71,IBDF("IEN")=103 ;provider, 1577 FEX
;S IBDF("PI")=73 ;patient active problems
;S IBDF("CLINIC")=300
S IBDF("PI")=7,IBDF("IEN")=14 ;provider, 1577 FEX
;S IBDF("PI")=73 ;patient active problems
S IBDF("DFN")=7169761
S IBDF("CLINIC")=88
D DYN(.VAR,.IBDF)
X "ZW VAR"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFRPC2 8358 printed Dec 13, 2024@02:53:20 Page 2
IBDFRPC2 ;ALB/AAS - Return list of selections, broker call ;29-JAN-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
+2 ;
SEL(RESULT,IBDF) ; -- Procedure
+1 ; -- called by ibdfrpc1, returns list for one selection list
+2 ; see ibdfrpc1 for complete input/output lists
+3 ; -- Input IBDF("IEN") := pointer to selection list (357.2)
+4 ; IBDF("PI") := pointer to package interface (357.6) (optional)
+5 ; IBDF("DFN") := pointer to patient (2) (optional)
+6 ; IBDF("CLINIC") := pointer to clinic (44) (optional)
+7 ;
+8 NEW OTEXT,TEXT,SC,TERM,COUNT,DCODE,SECOND,THIRD
+9 IF $EXTRACT($GET(RESULT),1)="^"
SET ARRY=RESULT
+10 IF '$TEST
SET ARRY="RESULT"
+11 SET COUNT=+$GET(@ARRY@(0))
+12 ;
+13 SET @ARRY@(0)="List not found"
+14 if '$GET(IBDF("IEN"))
GOTO SELQ
+15 if $GET(^IBE(357.2,IBDF("IEN"),0))=""
GOTO SELQ
+16 ;K ^TMP("IBD-DUP",$J)
+17 ;
+18 ; -- copy list
+19 IF '$GET(IBDF("RULE-ONLY"))
DO COPYLIST(.RESULT,IBDF("IEN"),.COUNT)
+20 ;I COUNT D URH
+21 ;
+22 SET @ARRY@(0)=COUNT_"^LIST^"
+23 DO GETQLF
SELQ QUIT
+1 ;
GETQLF ; -- add selection rule and qualifiers from marking area
+1 ; subcolumns to results(0) node, but only for bubbles
+2 NEW SC,NODE,BUBB,BUBBCNT
+3 SET SC=0
SET BUBBCNT=0
SET BUBB=$ORDER(^IBE(357.91,"B","BUBBLE (use for scanning)",0))
if 'BUBB
QUIT
+4 FOR
SET SC=$ORDER(^IBE(357.2,IBDF("IEN"),2,SC))
if 'SC
QUIT
Begin DoDot:1
+5 SET NODE=$GET(^IBE(357.2,IBDF("IEN"),2,SC,0))
+6 IF $PIECE(NODE,"^",4)=2
IF $PIECE(NODE,"^",6)=BUBB
SET BUBBCNT=BUBBCNT+1
SET @ARRY@(0)=@ARRY@(0)_$PIECE($GET(^IBD(357.98,+$PIECE(NODE,"^",9),0)),"^")_";;"_+$PIECE(NODE,"^",10)_"::"
End DoDot:1
+7 ;
+8 ; -- if no bubbles then kill off array, leave zero node for reports
+9 IF BUBBCNT<1
SET SC=@ARRY@(0)
KILL @ARRY
SET @ARRY@(0)="0^"_$PIECE(SC,"^",2,3)
SET $PIECE(@ARRY@(0),"^",4)=1
+10 QUIT
+11 ;
COPYLIST(RESULT,LIST,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
+1 ;
+2 NEW SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,GROUP,ORDER,HDR,CSUBCOL,DCODE,QUANTITY,SECOND,THIRD
+3 ;
+4 IF $EXTRACT($GET(RESULT),1)="^"
SET ARRY=RESULT
+5 IF '$TEST
SET ARRY="RESULT"
+6 ;
+7 SET SUBCOL=$$SUBCOL(LIST)
SET TSUBCOL=+SUBCOL
SET CSUBCOL=+$PIECE(SUBCOL,"^",2)
+8 ;
+9 SET PRNT=""
+10 FOR
SET PRNT=$ORDER(^IBE(357.4,"APO",LIST,PRNT))
if PRNT=""
QUIT
Begin DoDot:1
+11 SET GROUP=""
+12 FOR
SET GROUP=$ORDER(^IBE(357.4,"APO",LIST,PRNT,GROUP))
if GROUP=""
QUIT
Begin DoDot:2
+13 SET HDR=$PIECE($GET(^IBE(357.4,GROUP,0)),"^")
+14 IF $PIECE($GET(^IBE(357.4,GROUP,0)),"^",4)="I"
SET HDR=" "
+15 IF HDR="BLANK"
SET HDR=" "
+16 SET COUNT=COUNT+1
SET @ARRY@(COUNT)=HDR_"^^^^^^0"
+17 SET ORDER=""
+18 FOR
SET ORDER=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER))
if ORDER=""
QUIT
Begin DoDot:3
+19 SET SLCTN=0
+20 FOR
SET SLCTN=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:4
+21 SET (TEXT,DCODE,OTEXT,TERM,NOTREAL,IEN,SECOND,THIRD)=""
+22 SET NODE=$GET(^IBE(357.3,SLCTN,0))
SET IEN=$PIECE(NODE,"^")
+23 SET QUANTITY=$PIECE(NODE,"^",9)
+24 ;
+25 ; -- handle place holder as headers
+26 SET NOTREAL=$PIECE(NODE,"^",2)
+27 IF NOTREAL
IF $PIECE(NODE,"^",6)'=""
Begin DoDot:5
+28 IF $PIECE(NODE,"^",7)
SET COUNT=COUNT+1
SET HDR=$PIECE(NODE,"^",6)
SET @ARRY@(COUNT)=HDR_"^^^^^^0"
QUIT
+29 IF $PIECE(NODE,"^",8)
SET COUNT=COUNT+1
SET HDR=" "
SET @ARRY@(COUNT)=HDR_"^^^^^^0"
QUIT
+30 ;
End DoDot:5
QUIT
+31 ; -- find text for entry
+32 SET SUBCOL=$ORDER(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0))
+33 SET NODE=$GET(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
+34 if $PIECE(NODE,"^")=TSUBCOL
SET TEXT=$PIECE(NODE,"^",2)
+35 ;
+36 ; -- find display code for entry
+37 SET SUBCOL=$ORDER(^IBE(357.3,+SLCTN,1,"B",+CSUBCOL,0))
+38 SET NODE=$GET(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
+39 if $PIECE(NODE,"^")=CSUBCOL
SET DCODE=$PIECE(NODE,"^",2)
+40 ;
+41 ; -- find optional caption and lexicon pointer
+42 SET NODE=$GET(^IBE(357.3,SLCTN,2))
+43 SET OTEXT=$PIECE(NODE,"^")
SET TERM=$PIECE(NODE,"^",2)
+44 ;
+45 ; -- find optional second and third codes
+46 SET SECOND=$PIECE(NODE,"^",3)
SET THIRD=$PIECE(NODE,"^",4)
+47 ;
+48 ; -- add to array. Is dup ien or ien+text???
+49 IF $LENGTH(TEXT)
SET COUNT=COUNT+1
DO BLDA
QUIT
+50 ;I $L(TEXT),'$D(IBDUP(IEN_"^"_TEXT)) S COUNT=COUNT+1,IBDUP(IEN_"^"_TEXT)="" D BLDA Q ;this line checks ien+text for duplicates
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 KILL ^TMP("IBD-DUP",$JOB)
+53 QUIT
+54 ;
SUBCOL(LIST) ; -- function
+1 ; -- returns the subcolumn containing the text
+2 ; input LIST := selection list internal entry
+3 ; -- Assumes data returned by the package interface, piece 2 is the description
+4 ;
+5 NEW SC,TSUBCOL,CSUBCOL
+6 SET (TSUBCOL,CSUBCOL)=""
+7 SET SC=0
+8 FOR
SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
if 'SC
QUIT
Begin DoDot:1
+9 ;is a marking area
if $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",4)=2
QUIT
+10 ;data piece 2 is usually text subcol
IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)=2
SET TSUBCOL=$PIECE(^(0),"^")
QUIT
+11 ; data piece 1 is always code
IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)=1
SET CSUBCOL=$PIECE(^(0),"^")
QUIT
+12 ; -- see if other than data piece two is text subcolumn
IF TSUBCOL=""
IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)>2
SET TSUBCOL=$PIECE(^(0),"^")
QUIT
+13 IF CSUBCOL=""
IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)>2
SET CSUBCOL=$PIECE(^(0),"^")
QUIT
End DoDot:1
+14 QUIT TSUBCOL_"^"_CSUBCOL
+15 ;
BLDA ; -- build results array
+1 ;B ;;
SET @ARRY@(COUNT)=TEXT
+2 SET $PIECE(@ARRY@(COUNT),"^",2)=$GET(DCODE)
+3 SET $PIECE(@ARRY@(COUNT),"^",3)=$SELECT($GET(NOTREAL):"",1:$GET(IEN))
+4 SET $PIECE(@ARRY@(COUNT),"^",4)=""
+5 SET $PIECE(@ARRY@(COUNT),"^",5)=$GET(OTEXT)
+6 SET $PIECE(@ARRY@(COUNT),"^",6)=$GET(TERM)
+7 SET $PIECE(@ARRY@(COUNT),"^",7)=$SELECT($GET(NOTREAL):0,1:1)
+8 SET $PIECE(@ARRY@(COUNT),"^",9)=$GET(QUANTITY)
+9 SET $PIECE(@ARRY@(COUNT),"^",10)=$GET(SECOND)
+10 SET $PIECE(@ARRY@(COUNT),"^",11)=$GET(THIRD)
+11 ;--added for slctn to be passed also
+12 SET $PIECE(@ARRY@(COUNT),"^",12)=$GET(SLCTN)
+13 QUIT
+14 ;
URH ; -- UnReferenced Headers removal
+1 ; if a header doesn't have any data under it, then remove the header
+2 NEW X,HDR
+3 SET X=0
FOR
SET X=$ORDER(@ARRY@(X))
if 'X
QUIT
Begin DoDot:1
+4 ;find a header
IF '$DATA(HDR)
IF $PIECE(@ARRY@(X),"^",1)=""
SET HDR=X
QUIT
+5 ; is item under header
IF $PIECE(@ARRY@(X),"^",1)=""
KILL HDR
QUIT
+6 ;hdr doesn't have any items, kill hdr node and reset header to next header
IF $DATA(HDR)
IF $PIECE(@ARRY@(X),"^",1)=""
KILL @ARRY@(HDR)
SET COUNT=COUNT-1
SET HDR=X
End DoDot:1
+7 ;last item in list is a header
IF $DATA(HDR)
SET X=$ORDER(@ARRY@(""),-1)
IF $PIECE(@ARRY@(X),"^",1)=""
KILL @ARRY@(X)
SET COUNT=COUNT-1
SET HDR=X
+8 QUIT
+9 ;
DYN(RESULT,IBDF) ; -- Procedure
+1 ; -- called by ibdfrpc1 to return selection list for dynamic selections
+2 ; see ibdfrpc1 for complete input/output lists
+3 ; -- Input IBDF("PI") := pointer to package interface (357.6)
+4 ; IBDF("IEN") := pointer to selection list (357.2)
+5 ; IBDF("DFN") := pointer to patient (2) (optional for provider selections)
+6 ; IBDF("CLINIC") := pointer to clinic (44) (optional for active problem selections)
+7 ;
+8 NEW PI,DFN,CNT,COUNT,NAME,RTN,IBARY,IBCLINIC
+9 IF $EXTRACT($GET(RESULT),1)="^"
SET ARRY=RESULT
+10 IF '$TEST
SET ARRY="RESULT"
+11 SET COUNT=+$GET(@ARRY@(0))
+12 IF '$GET(IBDF("DFN"))
SET @ARRY@(0)="-1^Patient not defined"
GOTO DYNQ
+13 IF $GET(^DPT(+IBDF("DFN"),0))=""
SET @ARRY@(0)="-1^Patient not Found"
GOTO DYNQ
+14 SET DFN=+$GET(IBDF("DFN"))
+15 IF $GET(IBDF("RULE-ONLY"))
GOTO RULE
+16 ;
+17 SET @ARRY@(0)="List not found"
+18 if '$GET(IBDF("IEN"))
GOTO SELQ
+19 if $GET(^IBE(357.2,IBDF("IEN"),0))=""
GOTO DYNQ
+20 ;
+21 SET @ARRY@(0)="-1^Package Interface Not found"
+22 SET PI=$GET(^IBE(357.6,+$GET(IBDF("PI")),0))
IF PI=""
GOTO DYNQ
+23 ;
+24 SET IBCLINIC=$GET(IBDF("CLINIC"))
+25 IF +IBCLINIC'=IBCLINIC
IF IBCLINIC'=""
SET IBCLINIC=$ORDER(^SC("B",IBCLINIC,0))
+26 IF +IBCLINIC=0
SET @ARRY@(0)="Clinic Not Specified"
+27 ;
+28 SET NAME=$PIECE(PI,"^")
SET RTN=$PIECE(PI,"^",2,3)
IF RTN=""!(RTN="^")
GOTO DYNQ
+29 IF NAME["ACTIVE PROBLEM"
SET NAME="GMP SELECT PATIENT ACTIVE PROBLEMS"
+30 SET IBARY="^TMP(""IB"",$J,""INTERFACES"","""_NAME_""")"
+31 DO @RTN
+32 ;
+33 SET @ARRY@(0)=+$GET(@IBARY@(0))_"^LIST^"
RULE IF $GET(IBDF("RULE-ONLY"))
SET @ARRY@(0)="1^DYNLIST^"
+1 ;G DYNQ:@ARRY@(0)<1
+2 DO GETQLF
+3 if $GET(IBDF("RULE-ONLY"))
GOTO DYNQ
+4 ;
+5 SET CNT=0
FOR
SET CNT=$ORDER(@IBARY@(CNT))
if 'CNT
QUIT
Begin DoDot:1
+6 if $GET(@IBARY@(CNT))=""
QUIT
+7 ;
+8 ; -- Process provider lists
+9 IF NAME["PROVIDER"
Begin DoDot:2
+10 IF IBCLINIC<1
QUIT
+11 SET @ARRY@(CNT)=$PIECE(@IBARY@(CNT),"^",2)_"^^"_$PIECE(@IBARY@(CNT),"^",1)_"^^^^1"
QUIT
End DoDot:2
QUIT
+12 ;
+13 ; -- process patient active problem lists
+14 IF NAME["ACTIVE PROBLEMS"
Begin DoDot:2
+15 SET @ARRY@(CNT)=$PIECE(@IBARY@(CNT),"^",2)_"^"_$PIECE(@IBARY@(CNT),"^",3)_"^"_+@IBARY@(CNT)_"^^^^1"
End DoDot:2
QUIT
+16 IF '$DATA(@ARRY@(CNT))
SET @ARRY@(CNT)=@IBARY@(CNT)
End DoDot:1
+17 ;
DYNQ QUIT
+1 ;
+2 ; -- here are some sample tests for different lists
TEST KILL VAR,IBDF
+1 SET IBDF("IEN")=489
+2 DO SEL(.VAR,.IBDF)
+3 XECUTE "ZW VAR"
+4 QUIT
+5 ;
TEST1 KILL VAR,IBDF
+1 SET IBDF("IEN")=488
+2 DO SEL(.VAR,.IBDF)
+3 XECUTE "ZW VAR"
+4 QUIT
+5 ;
TESTD ; -- Test dynamic
+1 KILL VAR,IBDF
+2 ;S IBDF("PI")=71,IBDF("IEN")=103 ;provider, 1577 FEX
+3 ;S IBDF("PI")=73 ;patient active problems
+4 ;S IBDF("CLINIC")=300
+5 ;provider, 1577 FEX
SET IBDF("PI")=7
SET IBDF("IEN")=14
+6 ;S IBDF("PI")=73 ;patient active problems
+7 SET IBDF("DFN")=7169761
+8 SET IBDF("CLINIC")=88
+9 DO DYN(.VAR,.IBDF)
+10 XECUTE "ZW VAR"
