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 Dec 13, 2024@02:53:18 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 ;;
