IBDFRPC1 ;ALB/AAS - Return list of selections ; 2-JAN-96
;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
;
; -- used by AICS Data Entry Systems, IBDFDE2, IBDFDE3, IBDFDE4
;
OBJLST(RESULT,IBDF) ; -- Procedure
; -- Broker call to return any specified selection list, handprint field or multiple choice field
; rpc := IBD GET ONE INPUT OBJECT
;
; -- input RESULT := see output
; IBDF("PI") := package interface name or pointer
; IBDF("TYPE") := type of input object
; IBDF("IEN") := internal entry number of object
; IBDF("DFN") := pointer to patient (2) (required for patient active problems only)
; IBDF("CLINIC") := pointer to hospital location (44) (required for provider list only)
; IBDF("KILL") := 1 to kill results array prior to setting (Default) (optional)
;
; -- Output RESULT (called by reference)
; new for version 3.0 RESULT may be a closed global, i.e. ^tmp($j)
; and the data will be returned in ^tmp($j,n)
; For Lists:
; RESULT(0) := number of entries^type of input object (LIST)^qualifier;;selection rule[::qualifier;;selection rule)^no scannable bubbles(1 if not scannable)
; RESULTS(N) $P1 := Display text
; $P2 := Display code
; $P3 := input value (value to return)
; $P4 := input transform
; $P5 := optional caption
; $P6 := optional Term pointer
; $P7 := Selectable
;
; For Hand Print Fields
; RESULT(0) := 1^type of object (HP)^label^vitals type
; RESULT(1) := Text from form^print format in 359.1^MAX lenght^units^vitals Type^PCE DIM Units
;
; For Multiple Choice fields
; RESULT(0) := count of choices^type (MC)^display text^selection rule
; RESULT(n) := display text^label^value to return^qualifier^^^selectable (1)
;
N IBQUIT,LIST,CLINIC,CL1,PI,PKG,PKG1,DYN,ARRY,VALUE
S (IBQUIT,LIST)=0
;
I $E($G(RESULT),1)="^" S ARRY=RESULT
E S ARRY="RESULT"
I $G(IBDF("KILL"))="" S IBDF("KILL")=1
K:IBDF("KILL") @ARRY
;
S @ARRY@(0)="No package Interface found, 1"
; -- set pkg = ien of pkg interface from either b or e x-ref
S PKG=$G(IBDF("PI"))
I +PKG'=PKG,PKG'="" S PKG1=+$O(^IBE(357.6,"B",$E(PKG,1,30),0)) I 'PKG1 S PKG1=+$O(^IBE(357.6,"E",$E(PKG,1,40),0))
I $G(PKG1),'PKG S IBDF("PI")=PKG1
G:'$G(IBDF("PI")) OBJLSTQ
G:$G(^IBE(357.6,+IBDF("PI"),0))="" OBJLSTQ
;
I $G(IBDF("TYPE"))="" D
.S ITYP=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
.S IBDF("TYPE")=$S(ITYP=3:"LIST",ITYP=4:"MC",ITYP=5:"HP",1:"")
I $G(IBDF("TYPE"))="" S @ARRY@(0)="Object Type not determined" G OBJLSTQ
I "^LIST^MC^HP^"'[("^"_IBDF("TYPE")_"^") S @ARRY@(0)="Object type Unknown" G OBJLSTQ
;
;S FRM=$G(IBDF("FRM"))
;I +FRM'=FRM,FRM'="" S FRM=+$O(^IBE(357,"B",FRM,0))
;I 'FRM S FRM=$$DEFAULT^IBDFRPC S:FRM @ARRY@(0)="Using default form",IBDF("FRM")=FRM G:'FRM OBJLSTQ
;
; -- if type is selection list
I IBDF("TYPE")="LIST" D G OBJLSTQ
.S DYN=$P(^IBE(357.6,IBDF("PI"),0),"^",14)
.I 'DYN D SEL^IBDFRPC2(.RESULT,.IBDF)
.I DYN D DYN^IBDFRPC2(.RESULT,.IBDF)
;
; -- if type is multiple choice
I IBDF("TYPE")="MC" D MC G OBJLSTQ
;
; -- If type is Hand Print
I IBDF("TYPE")="HP" D HP G OBJLSTQ
;
S @ARRY@(0)="Processing did not occur"
;
OBJLSTQ Q
;
MC ; -- returns list from multiple choice fields
N X,DTEXT,SRULE,CHOICE,CH,CTEXT,CHLBL,CHID,CHQLF,CNT
S @ARRY@(0)="Multiple Choice Field not found"
G:'$G(IBDF("IEN")) MCQ
S X=$G(^IBE(357.93,IBDF("IEN"),0)) G:X="" MCQ
;
S DTEXT=$P(X,"^",2),SRULE=$P(X,"^",9)
;
S (CHOICE,CNT)=0
F S CHOICE=$O(^IBE(357.93,IBDF("IEN"),1,CHOICE)) Q:'CHOICE D
.S CH=$G(^IBE(357.93,IBDF("IEN"),1,CHOICE,0)) Q:CH=""
.S CTEXT=$P(CH,"^"),CHLBL=$P(CH,"^",5),CHID=$P(CH,"^",8)
.S CHQLF=$P(CH,"^",9),VALUE=$P($G(^IBD(357.98,+$G(CHQLF),0)),"^")
.S CNT=CNT+1
.S @ARRY@(CNT)=CTEXT_"^"_CHLBL_"^"_VALUE_"^"_CHQLF_"^^^1"
.Q
S @ARRY@(0)=CNT_"^MC^"_DTEXT_"^"_SRULE
MCQ Q
;
HP ; -- returns information on hand print field
N X,HNODE,HTEXT,HTYPE,HLEN,HPIC,HMEAS,VTYPE,VUNIT
S @ARRY@(0)="Hand Print field not found"
G:'$G(IBDF("IEN")) HPQ
S HNODE=$G(^IBE(359.94,IBDF("IEN"),0))
G:$G(HNODE)="" HPQ
S HTEXT=$P(HNODE,"^",2)
S HTYPE=$G(^IBE(359.1,+$P(HNODE,"^",10),0))
S HLEN=$P(HTYPE,"^",2),HPIC=$$FRMT^IBDF2F(HTYPE,$G(IBAPPT)),HMEAS=$P(HTYPE,"^",11),VTYPE=$P(HTYPE,"^",12),VUNIT=$P(HTYPE,"^",13)
S @ARRY@(1)=HTEXT_"^"_HPIC_"^"_HLEN_"^"_HMEAS_"^"_VTYPE_"^"_VUNIT
S @ARRY@(0)="1^HP^"_HTEXT_"^0"
;
HPQ Q
;
3 ; -- return lists of providers/cpts/diagnosis from form
; format as in 2
Q
;
4 ; -- provide list of other input items/and parameters
Q
;
TESTD ; -- test dynamic list
S IBDF("PI")=61
S IBDF("IEN")=1729
S IBDF("TYPE")="LIST"
S IBDF("CLINIC")=300
S IBDF("DFN")=1
D OBJLST(.TEST,.IBDF)
X "ZW TEST"
Q
;
TESTL ; -- test list
K TEST
S IBDF("PI")=7
S IBDF("IEN")=488
S IBDF("TYPE")="LIST"
D OBJLST("^TMP($J,""TESTL"")",.IBDF)
X "ZW TEST"
Q
;
TESTM ; -- test Multiple choice
K TEST
S IBDF("PI")=7
S IBDF("TYPE")="MC"
S IBDF("IEN")=161
D OBJLST("^TMP($J,""TESTM"")",.IBDF)
X "ZW TEST"
Q
TESTH ; -- test Hand Print
K TEST
S IBDF("PI")=95
S IBDF("TYPE")="HP"
S IBDF("IEN")=352
D OBJLST(.TEST,.IBDF)
X "ZW TEST"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFRPC1 5507 printed Oct 16, 2024@18:54:04 Page 2
IBDFRPC1 ;ALB/AAS - Return list of selections ; 2-JAN-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
+2 ;
+3 ; -- used by AICS Data Entry Systems, IBDFDE2, IBDFDE3, IBDFDE4
+4 ;
OBJLST(RESULT,IBDF) ; -- Procedure
+1 ; -- Broker call to return any specified selection list, handprint field or multiple choice field
+2 ; rpc := IBD GET ONE INPUT OBJECT
+3 ;
+4 ; -- input RESULT := see output
+5 ; IBDF("PI") := package interface name or pointer
+6 ; IBDF("TYPE") := type of input object
+7 ; IBDF("IEN") := internal entry number of object
+8 ; IBDF("DFN") := pointer to patient (2) (required for patient active problems only)
+9 ; IBDF("CLINIC") := pointer to hospital location (44) (required for provider list only)
+10 ; IBDF("KILL") := 1 to kill results array prior to setting (Default) (optional)
+11 ;
+12 ; -- Output RESULT (called by reference)
+13 ; new for version 3.0 RESULT may be a closed global, i.e. ^tmp($j)
+14 ; and the data will be returned in ^tmp($j,n)
+15 ; For Lists:
+16 ; RESULT(0) := number of entries^type of input object (LIST)^qualifier;;selection rule[::qualifier;;selection rule)^no scannable bubbles(1 if not scannable)
+17 ; RESULTS(N) $P1 := Display text
+18 ; $P2 := Display code
+19 ; $P3 := input value (value to return)
+20 ; $P4 := input transform
+21 ; $P5 := optional caption
+22 ; $P6 := optional Term pointer
+23 ; $P7 := Selectable
+24 ;
+25 ; For Hand Print Fields
+26 ; RESULT(0) := 1^type of object (HP)^label^vitals type
+27 ; RESULT(1) := Text from form^print format in 359.1^MAX lenght^units^vitals Type^PCE DIM Units
+28 ;
+29 ; For Multiple Choice fields
+30 ; RESULT(0) := count of choices^type (MC)^display text^selection rule
+31 ; RESULT(n) := display text^label^value to return^qualifier^^^selectable (1)
+32 ;
+33 NEW IBQUIT,LIST,CLINIC,CL1,PI,PKG,PKG1,DYN,ARRY,VALUE
+34 SET (IBQUIT,LIST)=0
+35 ;
+36 IF $EXTRACT($GET(RESULT),1)="^"
SET ARRY=RESULT
+37 IF '$TEST
SET ARRY="RESULT"
+38 IF $GET(IBDF("KILL"))=""
SET IBDF("KILL")=1
+39 if IBDF("KILL")
KILL @ARRY
+40 ;
+41 SET @ARRY@(0)="No package Interface found, 1"
+42 ; -- set pkg = ien of pkg interface from either b or e x-ref
+43 SET PKG=$GET(IBDF("PI"))
+44 IF +PKG'=PKG
IF PKG'=""
SET PKG1=+$ORDER(^IBE(357.6,"B",$EXTRACT(PKG,1,30),0))
IF 'PKG1
SET PKG1=+$ORDER(^IBE(357.6,"E",$EXTRACT(PKG,1,40),0))
+45 IF $GET(PKG1)
IF 'PKG
SET IBDF("PI")=PKG1
+46 if '$GET(IBDF("PI"))
GOTO OBJLSTQ
+47 if $GET(^IBE(357.6,+IBDF("PI"),0))=""
GOTO OBJLSTQ
+48 ;
+49 IF $GET(IBDF("TYPE"))=""
Begin DoDot:1
+50 SET ITYP=$PIECE($GET(^IBE(357.6,+IBDF("PI"),0)),"^")
+51 SET IBDF("TYPE")=$SELECT(ITYP=3:"LIST",ITYP=4:"MC",ITYP=5:"HP",1:"")
End DoDot:1
+52 IF $GET(IBDF("TYPE"))=""
SET @ARRY@(0)="Object Type not determined"
GOTO OBJLSTQ
+53 IF "^LIST^MC^HP^"'[("^"_IBDF("TYPE")_"^")
SET @ARRY@(0)="Object type Unknown"
GOTO OBJLSTQ
+54 ;
+55 ;S FRM=$G(IBDF("FRM"))
+56 ;I +FRM'=FRM,FRM'="" S FRM=+$O(^IBE(357,"B",FRM,0))
+57 ;I 'FRM S FRM=$$DEFAULT^IBDFRPC S:FRM @ARRY@(0)="Using default form",IBDF("FRM")=FRM G:'FRM OBJLSTQ
+58 ;
+59 ; -- if type is selection list
+60 IF IBDF("TYPE")="LIST"
Begin DoDot:1
+61 SET DYN=$PIECE(^IBE(357.6,IBDF("PI"),0),"^",14)
+62 IF 'DYN
DO SEL^IBDFRPC2(.RESULT,.IBDF)
+63 IF DYN
DO DYN^IBDFRPC2(.RESULT,.IBDF)
End DoDot:1
GOTO OBJLSTQ
+64 ;
+65 ; -- if type is multiple choice
+66 IF IBDF("TYPE")="MC"
DO MC
GOTO OBJLSTQ
+67 ;
+68 ; -- If type is Hand Print
+69 IF IBDF("TYPE")="HP"
DO HP
GOTO OBJLSTQ
+70 ;
+71 SET @ARRY@(0)="Processing did not occur"
+72 ;
OBJLSTQ QUIT
+1 ;
MC ; -- returns list from multiple choice fields
+1 NEW X,DTEXT,SRULE,CHOICE,CH,CTEXT,CHLBL,CHID,CHQLF,CNT
+2 SET @ARRY@(0)="Multiple Choice Field not found"
+3 if '$GET(IBDF("IEN"))
GOTO MCQ
+4 SET X=$GET(^IBE(357.93,IBDF("IEN"),0))
if X=""
GOTO MCQ
+5 ;
+6 SET DTEXT=$PIECE(X,"^",2)
SET SRULE=$PIECE(X,"^",9)
+7 ;
+8 SET (CHOICE,CNT)=0
+9 FOR
SET CHOICE=$ORDER(^IBE(357.93,IBDF("IEN"),1,CHOICE))
if 'CHOICE
QUIT
Begin DoDot:1
+10 SET CH=$GET(^IBE(357.93,IBDF("IEN"),1,CHOICE,0))
if CH=""
QUIT
+11 SET CTEXT=$PIECE(CH,"^")
SET CHLBL=$PIECE(CH,"^",5)
SET CHID=$PIECE(CH,"^",8)
+12 SET CHQLF=$PIECE(CH,"^",9)
SET VALUE=$PIECE($GET(^IBD(357.98,+$GET(CHQLF),0)),"^")
+13 SET CNT=CNT+1
+14 SET @ARRY@(CNT)=CTEXT_"^"_CHLBL_"^"_VALUE_"^"_CHQLF_"^^^1"
+15 QUIT
End DoDot:1
+16 SET @ARRY@(0)=CNT_"^MC^"_DTEXT_"^"_SRULE
MCQ QUIT
+1 ;
HP ; -- returns information on hand print field
+1 NEW X,HNODE,HTEXT,HTYPE,HLEN,HPIC,HMEAS,VTYPE,VUNIT
+2 SET @ARRY@(0)="Hand Print field not found"
+3 if '$GET(IBDF("IEN"))
GOTO HPQ
+4 SET HNODE=$GET(^IBE(359.94,IBDF("IEN"),0))
+5 if $GET(HNODE)=""
GOTO HPQ
+6 SET HTEXT=$PIECE(HNODE,"^",2)
+7 SET HTYPE=$GET(^IBE(359.1,+$PIECE(HNODE,"^",10),0))
+8 SET HLEN=$PIECE(HTYPE,"^",2)
SET HPIC=$$FRMT^IBDF2F(HTYPE,$GET(IBAPPT))
SET HMEAS=$PIECE(HTYPE,"^",11)
SET VTYPE=$PIECE(HTYPE,"^",12)
SET VUNIT=$PIECE(HTYPE,"^",13)
+9 SET @ARRY@(1)=HTEXT_"^"_HPIC_"^"_HLEN_"^"_HMEAS_"^"_VTYPE_"^"_VUNIT
+10 SET @ARRY@(0)="1^HP^"_HTEXT_"^0"
+11 ;
HPQ QUIT
+1 ;
3 ; -- return lists of providers/cpts/diagnosis from form
+1 ; format as in 2
+2 QUIT
+3 ;
4 ; -- provide list of other input items/and parameters
+1 QUIT
+2 ;
TESTD ; -- test dynamic list
+1 SET IBDF("PI")=61
+2 SET IBDF("IEN")=1729
+3 SET IBDF("TYPE")="LIST"
+4 SET IBDF("CLINIC")=300
+5 SET IBDF("DFN")=1
+6 DO OBJLST(.TEST,.IBDF)
+7 XECUTE "ZW TEST"
+8 QUIT
+9 ;
TESTL ; -- test list
+1 KILL TEST
+2 SET IBDF("PI")=7
+3 SET IBDF("IEN")=488
+4 SET IBDF("TYPE")="LIST"
+5 DO OBJLST("^TMP($J,""TESTL"")",.IBDF)
+6 XECUTE "ZW TEST"
+7 QUIT
+8 ;
TESTM ; -- test Multiple choice
+1 KILL TEST
+2 SET IBDF("PI")=7
+3 SET IBDF("TYPE")="MC"
+4 SET IBDF("IEN")=161
+5 DO OBJLST("^TMP($J,""TESTM"")",.IBDF)
+6 XECUTE "ZW TEST"
+7 QUIT
TESTH ; -- test Hand Print
+1 KILL TEST
+2 SET IBDF("PI")=95
+3 SET IBDF("TYPE")="HP"
+4 SET IBDF("IEN")=352
+5 DO OBJLST(.TEST,.IBDF)
+6 XECUTE "ZW TEST"
+7 QUIT
