- 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 Feb 19, 2025@00:19:44 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