IBDFCMP1 ;ALB/MAF - AICS list of components on a form (cont.); 29-JUL-96
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
;
EXP ;EXPAND
; -- expand action
N IBI,IBAT,VALMY,IBDVALM
S (IBDCNT,IBDCNT1,VALMCNT)=0
N IBDVALM,IBDAT,VALMY
S VALMBCK=""
D FULL^VALM1 S VALMBCK="R"
D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S IBDOBJ=$G(IBBLOCK(IBDVALM)) S (IBDCNT,IBDCNT1,VALMCNT)=0 D EN^VALM("IBDF COMPONENT EXPAND")
G REP
;
;
INIT K ^TMP("FORMEXP",$J),^TMP("EXPIDX") D
.S IBDFIFN=$P(IBDOBJ,"^")
.F IBDNUM=0:0 S IBDNUM=$O(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM)) Q:'IBDNUM I $P(IBDOBJ,"^",11)=$P($G(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM)),"^",9) D
..N IBDFSC,IBDFNUM,IBDFSEL,IBDFHP,IBDFMC,IBDFROW,IBDFCOL
..S (IBDFSC,IBDFNUM)=0
..S IBDOBJ1=$G(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM))
..S IBDF("PI")=+$P(IBDOBJ1,"^",2),IBDF("TYPE")=$P(IBDOBJ1,"^",5)
..S IBDF("IEN")=+$P(IBDOBJ1,"^",6),IBDF("VITAL")=$P(IBDOBJ1,"^",7)
..I $P(IBDOBJ1,"^",5)="LIST" D ;SELECTION LIST
...S IBDFSEL=$P(^IBE(357.2,$P(IBDOBJ1,"^",6),0),"^")
...S IBDFSNOD=$O(^IBE(357.2,$P(IBDOBJ1,"^",6),1,0)) S IBDFNODE=$G(^IBE(357.2,$P(IBDOBJ1,"^",6),1,+IBDFSNOD,0)) S IBDFSEL=IBDFSEL_"^"_$P(IBDFNODE,"^",4)_"^"_$P(IBDFNODE,"^",3) S IBDFROW=4,IBDFCOL=5 D SETUP(IBDFSEL,IBDFROW,IBDFCOL)
...F S IBDFSC=$O(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC)) Q:'IBDFSC F S IBDFNUM=$O(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC,IBDFNUM)) Q:'IBDFNUM S IBDFSEL=$G(^IBE(357.2,IBDF("IEN"),2,IBDFNUM,0)) D SETUP1(IBDFSEL)
..I $P(IBDOBJ1,"^",5)="MC" D ;MULTIPLE CHOICE
...S IBDFMC=$G(^IBE(357.93,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFMC,IBDFROW,IBDFCOL)
..I $P(IBDOBJ1,"^",5)="HP" D ;HAND PRINT FIELD
...S IBDFHP=$G(^IBE(359.94,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFHP,IBDFROW,IBDFCOL)
..I $P(IBDOBJ1,"^",5)="DF" D ;DATA FIELDS
...S IBDFDF=$G(^IBE(357.5,IBDF("IEN"),0)) S IBDFROW=11,IBDFCOL=10 D SETUP(IBDFDF,IBDFROW,IBDFCOL)
..I $P(IBDOBJ1,"^",5)="FL" D ;FORM LINE
...S IBDFFL=$G(^IBE(357.7,IBDF("IEN"),0)) S IBDFROW=3,IBDFCOL=2 D SETUP(IBDFFL,IBDFROW,IBDFCOL)
..I $P(IBDOBJ1,"^",5)="TA" D ;TEXT AREA
...S IBDFTA=$G(^IBE(357.8,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFTA,IBDFROW,IBDFCOL)
Q
;
;
REP ; -- Redisplay initial screen
S IBDFIFN=$S('$D(IBDFIFN):+$P(IBDOBJ,"^"),1:IBDFIFN) D INIT1^IBDFCMP S VALMBCK="R" Q
Q
;
;
SETUP(IBOBJECT,IBROW,IBCOL) ; -- Setting up the data for list manager
S IBDCNT1=IBDCNT1+1
S X=""
S X=$$SETSTR^VALM1(X,X,1,80) D TMP
S X="",X=$P(IBOBJECT,"^")
S X=$$SETSTR^VALM1(X,X,1,25)
S IBDVAL=$S($P(IBDOBJ1,"^",5)]"":$P(IBDOBJ1,"^",5),1:"")
S X=$$SETSTR^VALM1(IBDVAL,X,30,10)
S IBDVAL=$S($P(IBOBJECT,"^",IBROW):$P(IBOBJECT,"^",IBROW)+1,$P(IBOBJECT,"^",IBROW)=0:1,1:"N/A")
S X=$$SETSTR^VALM1($J(IBDVAL,3),X,48,6)
S IBDVAL=$S($P(IBOBJECT,"^",IBCOL):$P(IBOBJECT,"^",IBCOL)+1,$P(IBOBJECT,"^",IBCOL)=0:1,1:"N/A")
S X=$$SETSTR^VALM1($J(IBDVAL,4),X,58,5)
;D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
I X]"",$P(IBDOBJ1,"^",5)="LIST" D
.S IBDVAL=$S($P(^IBE(357.2,IBDF("IEN"),0),"^",7):$P(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
.S IBDVAL=$J($S(IBDVAL=1:"1 Space",IBDVAL=2:"2 Spaces",IBDVAL=3:"LINE",IBDVAL=4:"Sp/Ln/Sp",1:"N/A"),9)
.S X=$$SETSTR^VALM1(IBDVAL,X,71,9)
.D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
.S X="",X=$$SETSTR^VALM1(X,X,1,80) D TMP
.S IBDVAL=" "_"Subcolumn"_" "_"Type"_" "_"Data"_" "_"Width"_" "_"Qualifier"_" "_"Rule"_" "_"Edit"
.S X="",X=$$SETSTR^VALM1(IBDVAL,X,1,80) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
I $P(IBDOBJ1,"^",5)'="LIST" D
.D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
Q
SETUP1(IBOBJECT) ; -- Setup of the subcolumn info for the Selection list
S X=""
S X=$$SETSTR^VALM1($P(IBOBJECT,"^"),X,8,2)
S IBDVAL=$S($P(IBOBJECT,"^",4)]"":$P(IBOBJECT,"^",4),1:"")
S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=1:"TEXT",IBDVAL=2:"MARKING",1:"")),10)
S X=$$SETSTR^VALM1(IBDVAL,X,11,10)
S IBDVAL=$S($P(IBOBJECT,"^",5):$P(IBOBJECT,"^",5),1:"")
S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=1:"CODE",IBDVAL=2:"SHORT NAME",IBDVAL=3:"DESCRIP.",1:"N/A")),10)
S X=$$SETSTR^VALM1(IBDVAL,X,25,10)
S IBDVAL=$S($P(IBOBJECT,"^",3)]"":$P(IBOBJECT,"^",3),1:"")
S X=$$SETSTR^VALM1($J(IBDVAL,3),X,40,3)
S IBDVAL=$S($P(IBOBJECT,"^",3)]"":$P(IBOBJECT,"^",3),1:"")
S IBDVAL=$S($P(IBOBJECT,"^",9):$P(IBOBJECT,"^",9),1:"")
S IBDVAL=$P($G(^IBD(357.98,+IBDVAL,0)),"^",3)
S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL]"":IBDVAL,1:"N/A")),10)
S X=$$SETSTR^VALM1(IBDVAL,X,47,10)
S IBDVAL=$S($P(IBOBJECT,"^",10):$P(IBOBJECT,"^",10),1:"")
S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=0:"ANY NUMBER",IBDVAL=1:"ONLY 1",IBDVAL=2:"AT MOST 1",IBDVAL=3:"AT LEAST 1",1:"N/A")),10)
S X=$$SETSTR^VALM1(IBDVAL,X,59,10)
;I $P(IBDOBJ1,"^",5)="LIST" D
;S IBDVAL=$S($P(^IBE(357.2,IBDF("IEN"),0),"^",7):$P(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
;S IBDVAL=$S(IBDVAL=1:"1 S",IBDVAL=2:"2 S",IBDVAL=3:"LIN",IBDVAL=4:"SLS",1:"N/A")
S IBDVAL=$S($P(IBOBJECT,"^",7)=1:"Yes",1:"No")
S X=$$SETSTR^VALM1($J(IBDVAL,3),X,77,3)
D TMP
Q
;
;
TMP ; -- Set up Array
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S ^TMP("FORMEXP",$J,IBDCNT,0)=X,^TMP("FORMEXP",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("EXPIDX",$J,IBDCNT)=VALMCNT ;_"^"_IBDFIFN_"^"_IBDF("BLK")
Q
;
;
HDR ; -- print patient header
S X=""
S X=" Form Name: "_$E($P($G(^IBE(357,IBDFIFN,0)),"^"),1,25)
S VALMHDR(1)=X
S X=" Block Name: "_$E($P($G(^IBE(357.1,+$P(IBDOBJ,"^",11),0)),"^"),1,25)
S VALMHDR(2)=X
Q
;
;
EXIT ; -- Exit code
K ^TMP("FORMEXP",$J),^TMP("EXPIDX")
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFCMP1 5735 printed Apr 09, 2024@21:18:59 Page 2
IBDFCMP1 ;ALB/MAF - AICS list of components on a form (cont.); 29-JUL-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 ;
EXP ;EXPAND
+1 ; -- expand action
+2 NEW IBI,IBAT,VALMY,IBDVALM
+3 SET (IBDCNT,IBDCNT1,VALMCNT)=0
+4 NEW IBDVALM,IBDAT,VALMY
+5 SET VALMBCK=""
+6 DO FULL^VALM1
SET VALMBCK="R"
+7 DO EN^VALM2($GET(XQORNOD(0)))
if '$ORDER(VALMY(0))
GOTO REP
SET IBDVALM=0
+8 FOR IBDVALM=0:0
SET IBDVALM=$ORDER(VALMY(IBDVALM))
if 'IBDVALM
QUIT
SET IBDOBJ=$GET(IBBLOCK(IBDVALM))
SET (IBDCNT,IBDCNT1,VALMCNT)=0
DO EN^VALM("IBDF COMPONENT EXPAND")
+9 GOTO REP
+10 ;
+11 ;
INIT KILL ^TMP("FORMEXP",$JOB),^TMP("EXPIDX")
Begin DoDot:1
+1 SET IBDFIFN=$PIECE(IBDOBJ,"^")
+2 FOR IBDNUM=0:0
SET IBDNUM=$ORDER(^TMP("FORM-OBJ",$JOB,IBDFIFN,IBDNUM))
if 'IBDNUM
QUIT
IF $PIECE(IBDOBJ,"^",11)=$PIECE($GET(^TMP("FORM-OBJ",$JOB,IBDFIFN,IBDNUM)),"^",9)
Begin DoDot:2
+3 NEW IBDFSC,IBDFNUM,IBDFSEL,IBDFHP,IBDFMC,IBDFROW,IBDFCOL
+4 SET (IBDFSC,IBDFNUM)=0
+5 SET IBDOBJ1=$GET(^TMP("FORM-OBJ",$JOB,IBDFIFN,IBDNUM))
+6 SET IBDF("PI")=+$PIECE(IBDOBJ1,"^",2)
SET IBDF("TYPE")=$PIECE(IBDOBJ1,"^",5)
+7 SET IBDF("IEN")=+$PIECE(IBDOBJ1,"^",6)
SET IBDF("VITAL")=$PIECE(IBDOBJ1,"^",7)
+8 ;SELECTION LIST
IF $PIECE(IBDOBJ1,"^",5)="LIST"
Begin DoDot:3
+9 SET IBDFSEL=$PIECE(^IBE(357.2,$PIECE(IBDOBJ1,"^",6),0),"^")
+10 SET IBDFSNOD=$ORDER(^IBE(357.2,$PIECE(IBDOBJ1,"^",6),1,0))
SET IBDFNODE=$GET(^IBE(357.2,$PIECE(IBDOBJ1,"^",6),1,+IBDFSNOD,0))
SET IBDFSEL=IBDFSEL_"^"_$PIECE(IBDFNODE,"^",4)_"^"_$PIECE(IBDFNODE,"^",3)
SET IBDFROW=4
SET IBDFCOL=5
DO SETUP(IBDFSEL,IBDFROW,IBDFCOL)
+11 FOR
SET IBDFSC=$ORDER(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC))
if 'IBDFSC
QUIT
FOR
SET IBDFNUM=$ORDER(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC,IBDFNUM))
if 'IBDFNUM
QUIT
SET IBDFSEL=$GET(^IBE(357.2,IBDF("IEN"),2,IBDFNUM,0))
DO SETUP1(IBDFSEL)
End DoDot:3
+12 ;MULTIPLE CHOICE
IF $PIECE(IBDOBJ1,"^",5)="MC"
Begin DoDot:3
+13 SET IBDFMC=$GET(^IBE(357.93,IBDF("IEN"),0))
SET IBDFROW=4
SET IBDFCOL=3
DO SETUP(IBDFMC,IBDFROW,IBDFCOL)
End DoDot:3
+14 ;HAND PRINT FIELD
IF $PIECE(IBDOBJ1,"^",5)="HP"
Begin DoDot:3
+15 SET IBDFHP=$GET(^IBE(359.94,IBDF("IEN"),0))
SET IBDFROW=4
SET IBDFCOL=3
DO SETUP(IBDFHP,IBDFROW,IBDFCOL)
End DoDot:3
+16 ;DATA FIELDS
IF $PIECE(IBDOBJ1,"^",5)="DF"
Begin DoDot:3
+17 SET IBDFDF=$GET(^IBE(357.5,IBDF("IEN"),0))
SET IBDFROW=11
SET IBDFCOL=10
DO SETUP(IBDFDF,IBDFROW,IBDFCOL)
End DoDot:3
+18 ;FORM LINE
IF $PIECE(IBDOBJ1,"^",5)="FL"
Begin DoDot:3
+19 SET IBDFFL=$GET(^IBE(357.7,IBDF("IEN"),0))
SET IBDFROW=3
SET IBDFCOL=2
DO SETUP(IBDFFL,IBDFROW,IBDFCOL)
End DoDot:3
+20 ;TEXT AREA
IF $PIECE(IBDOBJ1,"^",5)="TA"
Begin DoDot:3
+21 SET IBDFTA=$GET(^IBE(357.8,IBDF("IEN"),0))
SET IBDFROW=4
SET IBDFCOL=3
DO SETUP(IBDFTA,IBDFROW,IBDFCOL)
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
+24 ;
REP ; -- Redisplay initial screen
+1 SET IBDFIFN=$SELECT('$DATA(IBDFIFN):+$PIECE(IBDOBJ,"^"),1:IBDFIFN)
DO INIT1^IBDFCMP
SET VALMBCK="R"
QUIT
+2 QUIT
+3 ;
+4 ;
SETUP(IBOBJECT,IBROW,IBCOL) ; -- Setting up the data for list manager
+1 SET IBDCNT1=IBDCNT1+1
+2 SET X=""
+3 SET X=$$SETSTR^VALM1(X,X,1,80)
DO TMP
+4 SET X=""
SET X=$PIECE(IBOBJECT,"^")
+5 SET X=$$SETSTR^VALM1(X,X,1,25)
+6 SET IBDVAL=$SELECT($PIECE(IBDOBJ1,"^",5)]"":$PIECE(IBDOBJ1,"^",5),1:"")
+7 SET X=$$SETSTR^VALM1(IBDVAL,X,30,10)
+8 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",IBROW):$PIECE(IBOBJECT,"^",IBROW)+1,$PIECE(IBOBJECT,"^",IBROW)=0:1,1:"N/A")
+9 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,48,6)
+10 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",IBCOL):$PIECE(IBOBJECT,"^",IBCOL)+1,$PIECE(IBOBJECT,"^",IBCOL)=0:1,1:"N/A")
+11 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,4),X,58,5)
+12 ;D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+13 IF X]""
IF $PIECE(IBDOBJ1,"^",5)="LIST"
Begin DoDot:1
+14 SET IBDVAL=$SELECT($PIECE(^IBE(357.2,IBDF("IEN"),0),"^",7):$PIECE(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
+15 SET IBDVAL=$JUSTIFY($SELECT(IBDVAL=1:"1 Space",IBDVAL=2:"2 Spaces",IBDVAL=3:"LINE",IBDVAL=4:"Sp/Ln/Sp",1:"N/A"),9)
+16 SET X=$$SETSTR^VALM1(IBDVAL,X,71,9)
+17 DO TMP
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+18 SET X=""
SET X=$$SETSTR^VALM1(X,X,1,80)
DO TMP
+19 SET IBDVAL=" "_"Subcolumn"_" "_"Type"_" "_"Data"_" "_"Width"_" "_"Qualifier"_" "_"Rule"_" "_"Edit"
+20 SET X=""
SET X=$$SETSTR^VALM1(IBDVAL,X,1,80)
DO TMP
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
End DoDot:1
+21 IF $PIECE(IBDOBJ1,"^",5)'="LIST"
Begin DoDot:1
+22 DO TMP
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
End DoDot:1
+23 QUIT
SETUP1(IBOBJECT) ; -- Setup of the subcolumn info for the Selection list
+1 SET X=""
+2 SET X=$$SETSTR^VALM1($PIECE(IBOBJECT,"^"),X,8,2)
+3 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",4)]"":$PIECE(IBOBJECT,"^",4),1:"")
+4 SET IBDVAL=$JUSTIFY($$LOWER^VALM1($SELECT(IBDVAL=1:"TEXT",IBDVAL=2:"MARKING",1:"")),10)
+5 SET X=$$SETSTR^VALM1(IBDVAL,X,11,10)
+6 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",5):$PIECE(IBOBJECT,"^",5),1:"")
+7 SET IBDVAL=$JUSTIFY($$LOWER^VALM1($SELECT(IBDVAL=1:"CODE",IBDVAL=2:"SHORT NAME",IBDVAL=3:"DESCRIP.",1:"N/A")),10)
+8 SET X=$$SETSTR^VALM1(IBDVAL,X,25,10)
+9 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",3)]"":$PIECE(IBOBJECT,"^",3),1:"")
+10 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,40,3)
+11 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",3)]"":$PIECE(IBOBJECT,"^",3),1:"")
+12 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",9):$PIECE(IBOBJECT,"^",9),1:"")
+13 SET IBDVAL=$PIECE($GET(^IBD(357.98,+IBDVAL,0)),"^",3)
+14 SET IBDVAL=$JUSTIFY($$LOWER^VALM1($SELECT(IBDVAL]"":IBDVAL,1:"N/A")),10)
+15 SET X=$$SETSTR^VALM1(IBDVAL,X,47,10)
+16 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",10):$PIECE(IBOBJECT,"^",10),1:"")
+17 SET IBDVAL=$JUSTIFY($$LOWER^VALM1($SELECT(IBDVAL=0:"ANY NUMBER",IBDVAL=1:"ONLY 1",IBDVAL=2:"AT MOST 1",IBDVAL=3:"AT LEAST 1",1:"N/A")),10)
+18 SET X=$$SETSTR^VALM1(IBDVAL,X,59,10)
+19 ;I $P(IBDOBJ1,"^",5)="LIST" D
+20 ;S IBDVAL=$S($P(^IBE(357.2,IBDF("IEN"),0),"^",7):$P(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
+21 ;S IBDVAL=$S(IBDVAL=1:"1 S",IBDVAL=2:"2 S",IBDVAL=3:"LIN",IBDVAL=4:"SLS",1:"N/A")
+22 SET IBDVAL=$SELECT($PIECE(IBOBJECT,"^",7)=1:"Yes",1:"No")
+23 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,77,3)
+24 DO TMP
+25 QUIT
+26 ;
+27 ;
TMP ; -- Set up Array
+1 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET ^TMP("FORMEXP",$JOB,IBDCNT,0)=X
SET ^TMP("FORMEXP",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+3 ;_"^"_IBDFIFN_"^"_IBDF("BLK")
SET ^TMP("EXPIDX",$JOB,IBDCNT)=VALMCNT
+4 QUIT
+5 ;
+6 ;
HDR ; -- print patient header
+1 SET X=""
+2 SET X=" Form Name: "_$EXTRACT($PIECE($GET(^IBE(357,IBDFIFN,0)),"^"),1,25)
+3 SET VALMHDR(1)=X
+4 SET X=" Block Name: "_$EXTRACT($PIECE($GET(^IBE(357.1,+$PIECE(IBDOBJ,"^",11),0)),"^"),1,25)
+5 SET VALMHDR(2)=X
+6 QUIT
+7 ;
+8 ;
EXIT ; -- Exit code
+1 KILL ^TMP("FORMEXP",$JOB),^TMP("EXPIDX")
+2 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
