- 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 Mar 13, 2025@21:58:22 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"
