- IBDFRPC ;ALB/AAS - AICS Return list of interfaces ; 2-JAN-96
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**1,23**;APR 24, 1997
- ;
- CLNLSTI(RESULT,CLINIC) ; -- Procedure
- ; -- Broker call to return list of data entry elements for a clinic/patient/form
- ; rpc := IBD GET INPUT OBJECT BY CLINIC
- ;
- ; -- input CLINIC = pointer to hospital location file or clinic name
- ; Result = called by reference or use a closed global root
- ;
- ; -- output The format of the returned array is as follows
- ; result(0) := count of array elements
- ; result(n) := $p1 := pkg interface name
- ; $p2 := pkg interface ien
- ; $p3 := form name
- ; $p4 := form type
- ; $p5 := type of input object
- ; $p6 := input object ien.
- ; $P7 := Vital Name (vitals only)
- ; $p8 := manual data entry supported
- ; $p9 := Block ien
- ; $p10 := block row
- ; $p11 := block column
- ;
- N I,J,X,Y,CL1,FTYP,IBDX,FRM,CNT
- ;
- I $E($G(RESULT),1)="^" S ARRY=RESULT
- E S ARRY="RESULT"
- ;
- K @ARRY S @ARRY@(0)="Clinic Not Found"
- I +CLINIC'=CLINIC,CLINIC'="" S CLINIC=+$O(^SC("B",CLINIC,0))
- G:'CLINIC CLNLSTQ
- ;
- ; -- find forms for clinic in clinic set up
- ; if no form, use default form from parameters
- S CL1=$O(^SD(409.95,"B",CLINIC,0))
- I 'CL1 D G CLNLSTQ
- .S @ARRY@(0)="No forms for Clinic"
- .S FRM=$$DEFAULT Q:'FRM
- .S @ARRY@(0)="Using Default Form"
- .D FRMLSTI(.RESULT,FRM,11,0)
- ;
- S IBDX=$G(^SD(409.95,CL1,0)) F FTYP=2,3,4,5,6,8,9 I $P(IBDX,"^",FTYP)'="" S FRM=$P(IBDX,"^",FTYP) D FRMLSTI(.RESULT,FRM,FTYP,0)
- ;
- CLNLSTQ Q
- ;
- FRMLSTI(RESULT,FRM,FTYP,KILL,ALLOBJ) ; -- procedure
- ; -- Broker call to return list of data entry elemets for one form
- ; rpc := IBD GET INPUT OBJECT BY FORM
- ;
- ; -- input FRM := pointer to encounter form file (357) or form name
- ; Result := Call by reference or use a closed global root
- ; FTYP := type of form for clinic (optional)
- ; KILL := 1 to kill results array prior to setting (default) (optional)
- ; ALLOBJ := 1 to return all form objects, not just input objs
- ; 0 to not kill array
- ;
- ; -- output The format of the returned array is as follows
- ; Result(0) := count of array elements
- ; Result(n) $p1 := pkg interface name
- ; $p2 := pkg interface ien
- ; $p3 := form name
- ; $p4 := form type
- ; $p5 := type of input object
- ; $p6 := input object ien.
- ; $p7 := Vital Name (vitals only)
- ; $p8 := manual data entry supported
- ; $p9 := Block ien
- ; $p10 := block row
- ; $p11 := block column
- ;
- N C,BLK,SEL,X,Y,ROW,COL,RESULT1,VITAL,CNT,ARRY,SEL1
- I $E($G(RESULT),1)="^" S ARRY=RESULT
- E S ARRY="RESULT"
- ;
- I +FRM'=FRM,FRM'="" S FRM=+$O(^IBE(357,"B",FRM,0))
- I 'FRM S FRM=$$DEFAULT S:FRM @ARRY@(0)="Using default form" G:'FRM FRMLSTQ
- I $G(FTYP)="" S FTYP=1
- I $G(KILL)="" S KILL=1 K:KILL @ARRY
- I $G(@ARRY@(0))="" S @ARRY@(0)="Form Not Found"
- I '$G(ALLOBJ),$P($G(^IBE(357,FRM,0)),"^",12)'=1 S @ARRY@(0)="Form not scannable" G FRMLSTQ
- ;
- ; -- first find all the blocks
- S X=0 F S X=$O(^IBE(357.1,"C",FRM,X)) Q:'X S BLK=X D
- .; -- get row and column of block
- .S ROW=$P($G(^IBE(357.1,+BLK,0)),"^",4),COL=$P(^(0),"^",5)
- .Q:ROW=""!(COL="")
- .;
- .; -- now find all the selection lists with input interfaces
- .S Y=0 F S Y=$O(^IBE(357.2,"C",BLK,Y)) Q:'Y D
- ..S SEL=+$P($G(^IBE(357.2,+Y,0)),"^",11)
- ..;I $P($G(^IBE(357.6,+SEL,0)),"^",13)'=""!($G(ALLOBJ)) D ; has input interface
- ..S SEL1=$P($G(^IBE(357.6,+SEL,0)),"^",13)
- ..I '$G(ALLOBJ) S SEL=SEL1
- ..I $G(ALLOBJ),SEL1'="" S SEL=SEL1
- ..Q:$G(^IBE(357.6,+SEL,0))=""
- ..D ADDIN(.RESULT1,FRM,FTYP,SEL,3,+Y,BLK,ROW,COL)
- ..Q
- .;
- .; -- find multiple choice fields
- .S Y=0 F S Y=$O(^IBE(357.93,"C",BLK,Y)) Q:'Y D
- ..S SEL=+$P($G(^IBE(357.93,+Y,0)),"^",6)
- ..I $P($G(^IBE(357.6,+SEL,0)),"^",13)'="" D
- ...S SEL=$P($G(^IBE(357.6,+SEL,0)),"^",13)
- ...Q:$G(^IBE(357.6,+SEL,0))=""
- ...D ADDIN(.RESULT1,FRM,FTYP,SEL,4,Y,BLK,ROW,COL)
- ..I $P($G(^IBE(357.6,+SEL,0)),"^",6)=1 D ADDIN(.RESULT1,FRM,FTYP,SEL,4,Y,BLK,ROW,COL)
- ..Q
- .;
- .; -- find Hand Print fields
- .S Y=0 F S Y=$O(^IBE(359.94,"C",BLK,Y)) Q:'Y D
- ..S SEL=+$P($G(^IBE(359.94,+Y,0)),"^",6)
- ..S VITAL=""
- ..I $P($G(^IBE(357.6,+SEL,0)),"^")["VITAL" S VITAL=$P($G(^IBE(359.1,+$P($G(^IBE(359.94,+Y,0)),"^",10),0)),"^")
- ..I $P($G(^IBE(357.6,+SEL,0)),"^",13)'="" D
- ...S SEL=$P($G(^IBE(357.6,+SEL,0)),"^",13)
- ...Q:$G(^IBE(357.6,+SEL,0))=""
- ...D ADDIN(.RESULT1,FRM,FTYP,SEL,5,Y,BLK,ROW,COL)
- ..I $P($G(^IBE(357.6,+SEL,0)),"^",6)=1 D ADDIN(.RESULT1,FRM,FTYP,SEL,5,Y,BLK,ROW,COL,VITAL)
- ..Q
- .;
- .I $G(ALLOBJ) D
- ..; find Data fields
- ..S Y=0 F S Y=$O(^IBE(357.5,"C",BLK,Y)) Q:'Y D ADDIN(.RESULT1,FRM,FTYP,+$P($G(^IBE(357.5,+Y,0)),"^",3),6,Y,BLK,ROW,COL)
- ..
- ..; find form lines
- ..S Y=0 F S Y=$O(^IBE(357.7,"C",BLK,Y)) Q:'Y D ADDIN(.RESULT1,FRM,FTYP,"FORM LINE",7,Y,BLK,ROW,COL)
- ..;
- ..; find text areas
- ..S Y=0 F S Y=$O(^IBE(357.8,"C",BLK,Y)) Q:'Y D ADDIN(.RESULT1,FRM,FTYP,"TEXT AREA",8,Y,BLK,ROW,COL)
- .Q
- ;
- ; -- now set results into single array
- S ROW="",CNT=+$G(@ARRY@(0))
- F S ROW=$O(RESULT1(ROW)) Q:ROW="" S COL="" F S COL=$O(RESULT1(ROW,COL)) Q:COL="" D
- .S C=0 F S C=$O(RESULT1(ROW,COL,C)) Q:C="" D
- ..S CNT=CNT+1
- ..S @ARRY@(CNT)=RESULT1(ROW,COL,C)
- S @ARRY@(0)=CNT
- K RESULT1
- ;
- FRMLSTQ Q
- ;
- ADDIN(RESULT1,FRM,FTYP,SEL,ITYP,ENTRY,BLK,ROW,COL,VITAL) ; --add to array
- N ITYPE1
- S ITYPE1=$S(ITYP=3:"LIST",ITYP=4:"MC",ITYP=5:"HP",ITYP=6:"DF",ITYP=7:"FL",ITYP=8:"TA",1:"OTHER")
- S RESULT1(0)=$G(RESULT1(0))+1
- S RESULT1(+ROW,+COL,RESULT1(0))=$S(+SEL:$P($G(^IBE(357.6,+SEL,0)),"^"),1:SEL)_"^"_SEL_"^"_$P($G(^IBE(357,+FRM,0)),"^")_"^"_$P($T(TYP+FTYP),";;",2)_"^"_ITYPE1_"^"_$G(ENTRY)_"^"_$G(VITAL)_"^"_$$MNL
- S RESULT1(+ROW,+COL,RESULT1(0))=RESULT1(+ROW,+COL,RESULT1(0))_"^"_$G(BLK)_"^"_$G(ROW)_"^"_$G(COL)
- Q
- ;
- MNL() ; -- is manual data entry supported
- Q $S($G(^IBE(357.6,+SEL,18))'="":1,1:0)
- ;
- DEFAULT() ; -- find default form from parameters
- N FRM
- S FRM=$P($G(^IBD(357.09,1,0)),"^",4)
- I FRM="" S FRM=$O(^IBE(357,"B","PRIMARY CARE SAMPLE V2.1",0))
- Q FRM
- ;
- TESTC ; -- test list by clinic
- K TEST
- D CLNLSTI(.TEST,25)
- X "ZW TEST"
- Q
- ;
- TESTF ; -- test list by form
- K TEST
- D FRMLSTI(.TEST,91)
- X "ZW TEST"
- Q
- ;
- TYP ; types of forms/from piece in 409.95
- ;;
- ;;BASIC FORM
- ;;SUPPLIMENTAL FORM, EST. PATIENTS
- ;;SUPPLEMENTAL FORM, FIRST VISIT
- ;;FORM W/O PATIENT DATA
- ;;SUPPLEMENTAL FORM
- ;;
- ;;SUPPLEMENTAL FORM
- ;;SUPPLEMENTAL FORM
- ;;
- ;;DEFAULT FORM
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFRPC 7007 printed Feb 19, 2025@00:19:43 Page 2
- IBDFRPC ;ALB/AAS - AICS Return list of interfaces ; 2-JAN-96
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**1,23**;APR 24, 1997
- +2 ;
- CLNLSTI(RESULT,CLINIC) ; -- Procedure
- +1 ; -- Broker call to return list of data entry elements for a clinic/patient/form
- +2 ; rpc := IBD GET INPUT OBJECT BY CLINIC
- +3 ;
- +4 ; -- input CLINIC = pointer to hospital location file or clinic name
- +5 ; Result = called by reference or use a closed global root
- +6 ;
- +7 ; -- output The format of the returned array is as follows
- +8 ; result(0) := count of array elements
- +9 ; result(n) := $p1 := pkg interface name
- +10 ; $p2 := pkg interface ien
- +11 ; $p3 := form name
- +12 ; $p4 := form type
- +13 ; $p5 := type of input object
- +14 ; $p6 := input object ien.
- +15 ; $P7 := Vital Name (vitals only)
- +16 ; $p8 := manual data entry supported
- +17 ; $p9 := Block ien
- +18 ; $p10 := block row
- +19 ; $p11 := block column
- +20 ;
- +21 NEW I,J,X,Y,CL1,FTYP,IBDX,FRM,CNT
- +22 ;
- +23 IF $EXTRACT($GET(RESULT),1)="^"
- SET ARRY=RESULT
- +24 IF '$TEST
- SET ARRY="RESULT"
- +25 ;
- +26 KILL @ARRY
- SET @ARRY@(0)="Clinic Not Found"
- +27 IF +CLINIC'=CLINIC
- IF CLINIC'=""
- SET CLINIC=+$ORDER(^SC("B",CLINIC,0))
- +28 if 'CLINIC
- GOTO CLNLSTQ
- +29 ;
- +30 ; -- find forms for clinic in clinic set up
- +31 ; if no form, use default form from parameters
- +32 SET CL1=$ORDER(^SD(409.95,"B",CLINIC,0))
- +33 IF 'CL1
- Begin DoDot:1
- +34 SET @ARRY@(0)="No forms for Clinic"
- +35 SET FRM=$$DEFAULT
- if 'FRM
- QUIT
- +36 SET @ARRY@(0)="Using Default Form"
- +37 DO FRMLSTI(.RESULT,FRM,11,0)
- End DoDot:1
- GOTO CLNLSTQ
- +38 ;
- +39 SET IBDX=$GET(^SD(409.95,CL1,0))
- FOR FTYP=2,3,4,5,6,8,9
- IF $PIECE(IBDX,"^",FTYP)'=""
- SET FRM=$PIECE(IBDX,"^",FTYP)
- DO FRMLSTI(.RESULT,FRM,FTYP,0)
- +40 ;
- CLNLSTQ QUIT
- +1 ;
- FRMLSTI(RESULT,FRM,FTYP,KILL,ALLOBJ) ; -- procedure
- +1 ; -- Broker call to return list of data entry elemets for one form
- +2 ; rpc := IBD GET INPUT OBJECT BY FORM
- +3 ;
- +4 ; -- input FRM := pointer to encounter form file (357) or form name
- +5 ; Result := Call by reference or use a closed global root
- +6 ; FTYP := type of form for clinic (optional)
- +7 ; KILL := 1 to kill results array prior to setting (default) (optional)
- +8 ; ALLOBJ := 1 to return all form objects, not just input objs
- +9 ; 0 to not kill array
- +10 ;
- +11 ; -- output The format of the returned array is as follows
- +12 ; Result(0) := count of array elements
- +13 ; Result(n) $p1 := pkg interface name
- +14 ; $p2 := pkg interface ien
- +15 ; $p3 := form name
- +16 ; $p4 := form type
- +17 ; $p5 := type of input object
- +18 ; $p6 := input object ien.
- +19 ; $p7 := Vital Name (vitals only)
- +20 ; $p8 := manual data entry supported
- +21 ; $p9 := Block ien
- +22 ; $p10 := block row
- +23 ; $p11 := block column
- +24 ;
- +25 NEW C,BLK,SEL,X,Y,ROW,COL,RESULT1,VITAL,CNT,ARRY,SEL1
- +26 IF $EXTRACT($GET(RESULT),1)="^"
- SET ARRY=RESULT
- +27 IF '$TEST
- SET ARRY="RESULT"
- +28 ;
- +29 IF +FRM'=FRM
- IF FRM'=""
- SET FRM=+$ORDER(^IBE(357,"B",FRM,0))
- +30 IF 'FRM
- SET FRM=$$DEFAULT
- if FRM
- SET @ARRY@(0)="Using default form"
- if 'FRM
- GOTO FRMLSTQ
- +31 IF $GET(FTYP)=""
- SET FTYP=1
- +32 IF $GET(KILL)=""
- SET KILL=1
- if KILL
- KILL @ARRY
- +33 IF $GET(@ARRY@(0))=""
- SET @ARRY@(0)="Form Not Found"
- +34 IF '$GET(ALLOBJ)
- IF $PIECE($GET(^IBE(357,FRM,0)),"^",12)'=1
- SET @ARRY@(0)="Form not scannable"
- GOTO FRMLSTQ
- +35 ;
- +36 ; -- first find all the blocks
- +37 SET X=0
- FOR
- SET X=$ORDER(^IBE(357.1,"C",FRM,X))
- if 'X
- QUIT
- SET BLK=X
- Begin DoDot:1
- +38 ; -- get row and column of block
- +39 SET ROW=$PIECE($GET(^IBE(357.1,+BLK,0)),"^",4)
- SET COL=$PIECE(^(0),"^",5)
- +40 if ROW=""!(COL="")
- QUIT
- +41 ;
- +42 ; -- now find all the selection lists with input interfaces
- +43 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(357.2,"C",BLK,Y))
- if 'Y
- QUIT
- Begin DoDot:2
- +44 SET SEL=+$PIECE($GET(^IBE(357.2,+Y,0)),"^",11)
- +45 ;I $P($G(^IBE(357.6,+SEL,0)),"^",13)'=""!($G(ALLOBJ)) D ; has input interface
- +46 SET SEL1=$PIECE($GET(^IBE(357.6,+SEL,0)),"^",13)
- +47 IF '$GET(ALLOBJ)
- SET SEL=SEL1
- +48 IF $GET(ALLOBJ)
- IF SEL1'=""
- SET SEL=SEL1
- +49 if $GET(^IBE(357.6,+SEL,0))=""
- QUIT
- +50 DO ADDIN(.RESULT1,FRM,FTYP,SEL,3,+Y,BLK,ROW,COL)
- +51 QUIT
- End DoDot:2
- +52 ;
- +53 ; -- find multiple choice fields
- +54 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(357.93,"C",BLK,Y))
- if 'Y
- QUIT
- Begin DoDot:2
- +55 SET SEL=+$PIECE($GET(^IBE(357.93,+Y,0)),"^",6)
- +56 IF $PIECE($GET(^IBE(357.6,+SEL,0)),"^",13)'=""
- Begin DoDot:3
- +57 SET SEL=$PIECE($GET(^IBE(357.6,+SEL,0)),"^",13)
- +58 if $GET(^IBE(357.6,+SEL,0))=""
- QUIT
- +59 DO ADDIN(.RESULT1,FRM,FTYP,SEL,4,Y,BLK,ROW,COL)
- End DoDot:3
- +60 IF $PIECE($GET(^IBE(357.6,+SEL,0)),"^",6)=1
- DO ADDIN(.RESULT1,FRM,FTYP,SEL,4,Y,BLK,ROW,COL)
- +61 QUIT
- End DoDot:2
- +62 ;
- +63 ; -- find Hand Print fields
- +64 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(359.94,"C",BLK,Y))
- if 'Y
- QUIT
- Begin DoDot:2
- +65 SET SEL=+$PIECE($GET(^IBE(359.94,+Y,0)),"^",6)
- +66 SET VITAL=""
- +67 IF $PIECE($GET(^IBE(357.6,+SEL,0)),"^")["VITAL"
- SET VITAL=$PIECE($GET(^IBE(359.1,+$PIECE($GET(^IBE(359.94,+Y,0)),"^",10),0)),"^")
- +68 IF $PIECE($GET(^IBE(357.6,+SEL,0)),"^",13)'=""
- Begin DoDot:3
- +69 SET SEL=$PIECE($GET(^IBE(357.6,+SEL,0)),"^",13)
- +70 if $GET(^IBE(357.6,+SEL,0))=""
- QUIT
- +71 DO ADDIN(.RESULT1,FRM,FTYP,SEL,5,Y,BLK,ROW,COL)
- End DoDot:3
- +72 IF $PIECE($GET(^IBE(357.6,+SEL,0)),"^",6)=1
- DO ADDIN(.RESULT1,FRM,FTYP,SEL,5,Y,BLK,ROW,COL,VITAL)
- +73 QUIT
- End DoDot:2
- +74 ;
- +75 IF $GET(ALLOBJ)
- Begin DoDot:2
- +76 ; find Data fields
- +77 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(357.5,"C",BLK,Y))
- if 'Y
- QUIT
- DO ADDIN(.RESULT1,FRM,FTYP,+$PIECE($GET(^IBE(357.5,+Y,0)),"^",3),6,Y,BLK,ROW,COL)
- +78 +79 ; find form lines
- +80 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(357.7,"C",BLK,Y))
- if 'Y
- QUIT
- DO ADDIN(.RESULT1,FRM,FTYP,"FORM LINE",7,Y,BLK,ROW,COL)
- +81 ;
- +82 ; find text areas
- +83 SET Y=0
- FOR
- SET Y=$ORDER(^IBE(357.8,"C",BLK,Y))
- if 'Y
- QUIT
- DO ADDIN(.RESULT1,FRM,FTYP,"TEXT AREA",8,Y,BLK,ROW,COL)
- End DoDot:2
- +84 QUIT
- End DoDot:1
- +85 ;
- +86 ; -- now set results into single array
- +87 SET ROW=""
- SET CNT=+$GET(@ARRY@(0))
- +88 FOR
- SET ROW=$ORDER(RESULT1(ROW))
- if ROW=""
- QUIT
- SET COL=""
- FOR
- SET COL=$ORDER(RESULT1(ROW,COL))
- if COL=""
- QUIT
- Begin DoDot:1
- +89 SET C=0
- FOR
- SET C=$ORDER(RESULT1(ROW,COL,C))
- if C=""
- QUIT
- Begin DoDot:2
- +90 SET CNT=CNT+1
- +91 SET @ARRY@(CNT)=RESULT1(ROW,COL,C)
- End DoDot:2
- End DoDot:1
- +92 SET @ARRY@(0)=CNT
- +93 KILL RESULT1
- +94 ;
- FRMLSTQ QUIT
- +1 ;
- ADDIN(RESULT1,FRM,FTYP,SEL,ITYP,ENTRY,BLK,ROW,COL,VITAL) ; --add to array
- +1 NEW ITYPE1
- +2 SET ITYPE1=$SELECT(ITYP=3:"LIST",ITYP=4:"MC",ITYP=5:"HP",ITYP=6:"DF",ITYP=7:"FL",ITYP=8:"TA",1:"OTHER")
- +3 SET RESULT1(0)=$GET(RESULT1(0))+1
- +4 SET RESULT1(+ROW,+COL,RESULT1(0))=$SELECT(+SEL:$PIECE($GET(^IBE(357.6,+SEL,0)),"^"),1:SEL)_"^"_SEL_"^"_$PIECE($GET(^IBE(357,+FRM,0)),"^")_"^"_$PIECE($TEXT(TYP+FTYP),";;",2)_"^"_ITYPE1_"^"_$GET(ENTRY)_"^"_$GET(VITAL)_"^"_$$MNL
- +5 SET RESULT1(+ROW,+COL,RESULT1(0))=RESULT1(+ROW,+COL,RESULT1(0))_"^"_$GET(BLK)_"^"_$GET(ROW)_"^"_$GET(COL)
- +6 QUIT
- +7 ;
- MNL() ; -- is manual data entry supported
- +1 QUIT $SELECT($GET(^IBE(357.6,+SEL,18))'="":1,1:0)
- +2 ;
- DEFAULT() ; -- find default form from parameters
- +1 NEW FRM
- +2 SET FRM=$PIECE($GET(^IBD(357.09,1,0)),"^",4)
- +3 IF FRM=""
- SET FRM=$ORDER(^IBE(357,"B","PRIMARY CARE SAMPLE V2.1",0))
- +4 QUIT FRM
- +5 ;
- TESTC ; -- test list by clinic
- +1 KILL TEST
- +2 DO CLNLSTI(.TEST,25)
- +3 XECUTE "ZW TEST"
- +4 QUIT
- +5 ;
- TESTF ; -- test list by form
- +1 KILL TEST
- +2 DO FRMLSTI(.TEST,91)
- +3 XECUTE "ZW TEST"
- +4 QUIT
- +5 ;
- TYP ; types of forms/from piece in 409.95
- +1 ;;
- +2 ;;BASIC FORM
- +3 ;;SUPPLIMENTAL FORM, EST. PATIENTS
- +4 ;;SUPPLEMENTAL FORM, FIRST VISIT
- +5 ;;FORM W/O PATIENT DATA
- +6 ;;SUPPLEMENTAL FORM
- +7 ;;
- +8 ;;SUPPLEMENTAL FORM
- +9 ;;SUPPLEMENTAL FORM
- +10 ;;
- +11 ;;DEFAULT FORM
- +12 ;;