IBDFCMP ;ALB/MAF - AICS list of components on a form ; 29-JUL-96
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
START K XQORS,VALMEVL D EN^VALM("IBDF FORM COMPONENTS")
Q
INIT ;
% N I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE,IBDFALL
I '$D(DT) D DT^DICRW
D HOME^%ZIS
W !!,"Display Form Components",!!
;
; -- ask for form id
D END
S DIR("?")="Enter the Encounter Form Name you want to review."
S DIR(0)="PO^357:AEQM",DIR("A")="Select Encounter Form" D ^DIR K DIR,DA,DR,DIC
I $D(DIRUT) S VALMBCK="Q",VALMQUIT=1 Q
S IBDFIFN=+Y
INIT1 S IBDCNT1=0,IBDCNT=0,VALMCNT=0
D DQ
;
STRTQ G:$G(IBQUIT) END ;D PAUSE^IBDFDE
Q
;
DQ ; -- entry point to list contents of one form,
; Input IBDFIFN := pointer to Encounter Form (357)
;
S IBQUIT=0
I '$D(^TMP("FORM-OBJ",$J,IBDFIFN,0)) S IBDFALL=1 D FRMLSTI^IBDFRPC(.IBDOBJ,IBDFIFN,"",1,IBDFALL) M ^TMP("FORM-OBJ",$J,IBDFIFN)=IBDOBJ K IBDOBJ
I $D(^TMP("FORM-OBJ",$J,IBDFIFN,0)),^TMP("FORM-OBJ",$J,IBDFIFN,0)'>0 D NUL Q
D LISTOB
Q
;
LISTOB ; -- list items available for input on a form
N IBDFOLDB
S IBDFOLDB=0
S I=0 F S I=$O(^TMP("FORM-OBJ",$J,IBDFIFN,I)) Q:I=""!(IBQUIT) D
.S IBDOBJ=$G(^TMP("FORM-OBJ",$J,IBDFIFN,I))
.S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
.S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
.S IBDF("BROW")=+$P(IBDOBJ,"^",10)+1,IBDF("BCOL")=+$P(IBDOBJ,"^",11)+1
.S IBDF("BLK")=+$P(IBDOBJ,"^",9),IBDF("BNAME")=$P($G(^IBE(357.1,IBDF("BLK"),0)),"^"),IBDF("BNODE")=$G(^IBE(357.1,IBDF("BLK"),0))
.S IBDF("HT")=$P(IBDF("BNODE"),"^",7)
.S IBDF("WDTH")=$P(IBDF("BNODE"),"^",6)
.S IBDF("TKO")=$P(IBDF("BNODE"),"^",14)
.I IBDFOLDB'=$P(IBDOBJ,"^",9) S IBDFFLAG=0
.I 'IBDFFLAG D
..S X=""
..S IBDFFLAG=1,IBDFOLDB=$P(IBDOBJ,"^",9)
..S IBDCNT1=IBDCNT1+1
..S X=$$SETSTR^VALM1(X,X,1,80) D TMP
..S X=""
..S IBDVAL=IBDCNT1_") "
..S X=$$SETSTR^VALM1(IBDVAL,X,1,4)
..S X=$$SETSTR^VALM1($P(IBDF("BNAME"),"^",1),X,5,40) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
..S IBBLOCK(IBDCNT1)=IBDFIFN_"^"_IBDCNT_"^"_IBDOBJ
..S X="",X=$$SETSTR^VALM1($$LOWER^VALM1(" STARTING ROW: "),X,1,16)
..S IBDVAL=$S(IBDF("BROW"):IBDF("BROW"),1:"")
..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,17,3)
..S X=$$SETSTR^VALM1($$LOWER^VALM1("STARTING COLUMN: "),X,49,17)
..S IBDVAL=$S(IBDF("BCOL"):IBDF("BCOL"),1:"")
..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,66,3) D TMP
..S X="",X=$$SETSTR^VALM1($$LOWER^VALM1(" BLOCK WIDTH: "),X,1,16)
..S IBDVAL=$S(IBDF("WDTH"):IBDF("WDTH"),1:"")
..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,17,3)
..S X=$$SETSTR^VALM1($$LOWER^VALM1(" BLOCK HEIGHT: "),X,49,17)
..S IBDVAL=$S(IBDF("HT"):IBDF("HT"),1:"")
..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,66,3) D TMP
Q
TMP ; -- Set up Array
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S ^TMP("FORMOBJ",$J,IBDCNT,0)=X,^TMP("FORMOBJ",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("FORMIDX",$J,IBDCNT)=VALMCNT_"^"_IBDFIFN_"^"_IBDF("BLK")
Q
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
;
EXIT ; -- exit code
K IBDCAT,IBDNME,IBDTYPE,VALMCNT,IBDCNT,IBDCNT1,IBDNAME,IBDNUM,IBDNME,IBDFIFN,IBDVAL,IBDNODE,IBFASTXT,IBDF,IBBLOCK,IBDFNODE,IBDFSNOD,IBDFOBJ,IBDOBJ1,IBQUIT,IBDFFLAG,IBDOBJ
K ^TMP("FORM-OBJ",$J),^TMP("FORMIDX",$J),^TMP("FORMOBJ",$J)
Q
;
NUL ; -- NULL MESSAGE
S ^TMP("FORMOBJ",$J,1,0)=" ",^TMP("FORMOBJ",$J,2,0)="There are no Components listed for this form.",^TMP("FORMIDX",$J,1)=1,^TMP("FORMIDX",$J,2)=2
Q
;
HDR ; -- print patient header
;Q:'$D(IBDFIFN)
S X=" Form Name: "_$E($P($G(^IBE(357,+IBDFIFN,0)),"^"),1,25)
S IBDVAL="FORM ID #: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",13):$P(^IBE(357,+IBDFIFN,0),"^",13),1:"")
S VALMHDR(1)=$$SETSTR^VALM1(IBDVAL,X,55,25)
S X=" Status: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",5):"Compiled",1:"Uncompiled")
S IBDVAL=" Toolkit: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",7):"Yes",1:"No")
S VALMHDR(2)=$$SETSTR^VALM1(IBDVAL,X,55,25)
S X=" Scannable: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",12):"Yes",1:"No")
S IBDVAL=" Use ICR: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",6):"Yes",1:"No")
S VALMHDR(3)=$$SETSTR^VALM1(IBDVAL,X,55,25)
S X=+$P($G(^IBE(357,+IBDFIFN,0)),"^",2)
S X="Simplex/Duplex: "_$S(X]""&(X=0):"Simplex",X]""&(X=1):"Duplex Long-Edge",X]""&(X=2):"Duplex Short-Edge",1:"")
S IBDVAL=" # Pages: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",11):+$P($G(^IBE(357,+IBDFIFN,0)),"^",11),1:"0")
S VALMHDR(4)=$$SETSTR^VALM1(IBDVAL,X,55,25)
Q
;
END I $D(ZTQUEUED) S ZTREQ="@" Q
K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK,IBDFIFN
K ^TMP("FORMIDX",$J),^TMP("FORM-OBJ",$J),^TMP("FORMOBJ",$J)
D ^%ZISC
Q
;
EXP ; -- Expand Action
D FULL^VALM1
N VALMI,VALMAT,VALMY
D EN^VALM2(XQORNOD(0),"O") S VALMI=0
F S VALMI=$O(VALMY(VALMI)) Q:'VALMI D
.S VALMAT=$G(IBBLOCK(VALMI))
.W !
.I DUZ(0)="@" W !,"Entry No. ",+$P(VALMAT,"^",11)
.S DA=+$P(VALMAT,U,11),DIC="^IBE(357.1,",DR="0" D EN^DIQ,PAUSE^VALM1
.K DA,DIC,DR
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFCMP 5066 printed Nov 22, 2024@18:02:17 Page 2
IBDFCMP ;ALB/MAF - AICS list of components on a form ; 29-JUL-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
START KILL XQORS,VALMEVL
DO EN^VALM("IBDF FORM COMPONENTS")
+1 QUIT
INIT ;
% NEW I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE,IBDFALL
+1 IF '$DATA(DT)
DO DT^DICRW
+2 DO HOME^%ZIS
+3 WRITE !!,"Display Form Components",!!
+4 ;
+5 ; -- ask for form id
+6 DO END
+7 SET DIR("?")="Enter the Encounter Form Name you want to review."
+8 SET DIR(0)="PO^357:AEQM"
SET DIR("A")="Select Encounter Form"
DO ^DIR
KILL DIR,DA,DR,DIC
+9 IF $DATA(DIRUT)
SET VALMBCK="Q"
SET VALMQUIT=1
QUIT
+10 SET IBDFIFN=+Y
INIT1 SET IBDCNT1=0
SET IBDCNT=0
SET VALMCNT=0
+1 DO DQ
+2 ;
STRTQ ;D PAUSE^IBDFDE
if $GET(IBQUIT)
GOTO END
+1 QUIT
+2 ;
DQ ; -- entry point to list contents of one form,
+1 ; Input IBDFIFN := pointer to Encounter Form (357)
+2 ;
+3 SET IBQUIT=0
+4 IF '$DATA(^TMP("FORM-OBJ",$JOB,IBDFIFN,0))
SET IBDFALL=1
DO FRMLSTI^IBDFRPC(.IBDOBJ,IBDFIFN,"",1,IBDFALL)
MERGE ^TMP("FORM-OBJ",$JOB,IBDFIFN)=IBDOBJ
KILL IBDOBJ
+5 IF $DATA(^TMP("FORM-OBJ",$JOB,IBDFIFN,0))
IF ^TMP("FORM-OBJ",$JOB,IBDFIFN,0)'>0
DO NUL
QUIT
+6 DO LISTOB
+7 QUIT
+8 ;
LISTOB ; -- list items available for input on a form
+1 NEW IBDFOLDB
+2 SET IBDFOLDB=0
+3 SET I=0
FOR
SET I=$ORDER(^TMP("FORM-OBJ",$JOB,IBDFIFN,I))
if I=""!(IBQUIT)
QUIT
Begin DoDot:1
+4 SET IBDOBJ=$GET(^TMP("FORM-OBJ",$JOB,IBDFIFN,I))
+5 SET IBDF("PI")=+$PIECE(IBDOBJ,"^",2)
SET IBDF("TYPE")=$PIECE(IBDOBJ,"^",5)
+6 SET IBDF("IEN")=+$PIECE(IBDOBJ,"^",6)
SET IBDF("VITAL")=$PIECE(IBDOBJ,"^",7)
+7 SET IBDF("BROW")=+$PIECE(IBDOBJ,"^",10)+1
SET IBDF("BCOL")=+$PIECE(IBDOBJ,"^",11)+1
+8 SET IBDF("BLK")=+$PIECE(IBDOBJ,"^",9)
SET IBDF("BNAME")=$PIECE($GET(^IBE(357.1,IBDF("BLK"),0)),"^")
SET IBDF("BNODE")=$GET(^IBE(357.1,IBDF("BLK"),0))
+9 SET IBDF("HT")=$PIECE(IBDF("BNODE"),"^",7)
+10 SET IBDF("WDTH")=$PIECE(IBDF("BNODE"),"^",6)
+11 SET IBDF("TKO")=$PIECE(IBDF("BNODE"),"^",14)
+12 IF IBDFOLDB'=$PIECE(IBDOBJ,"^",9)
SET IBDFFLAG=0
+13 IF 'IBDFFLAG
Begin DoDot:2
+14 SET X=""
+15 SET IBDFFLAG=1
SET IBDFOLDB=$PIECE(IBDOBJ,"^",9)
+16 SET IBDCNT1=IBDCNT1+1
+17 SET X=$$SETSTR^VALM1(X,X,1,80)
DO TMP
+18 SET X=""
+19 SET IBDVAL=IBDCNT1_") "
+20 SET X=$$SETSTR^VALM1(IBDVAL,X,1,4)
+21 SET X=$$SETSTR^VALM1($PIECE(IBDF("BNAME"),"^",1),X,5,40)
DO TMP
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+22 SET IBBLOCK(IBDCNT1)=IBDFIFN_"^"_IBDCNT_"^"_IBDOBJ
+23 SET X=""
SET X=$$SETSTR^VALM1($$LOWER^VALM1(" STARTING ROW: "),X,1,16)
+24 SET IBDVAL=$SELECT(IBDF("BROW"):IBDF("BROW"),1:"")
+25 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,17,3)
+26 SET X=$$SETSTR^VALM1($$LOWER^VALM1("STARTING COLUMN: "),X,49,17)
+27 SET IBDVAL=$SELECT(IBDF("BCOL"):IBDF("BCOL"),1:"")
+28 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,66,3)
DO TMP
+29 SET X=""
SET X=$$SETSTR^VALM1($$LOWER^VALM1(" BLOCK WIDTH: "),X,1,16)
+30 SET IBDVAL=$SELECT(IBDF("WDTH"):IBDF("WDTH"),1:"")
+31 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,17,3)
+32 SET X=$$SETSTR^VALM1($$LOWER^VALM1(" BLOCK HEIGHT: "),X,49,17)
+33 SET IBDVAL=$SELECT(IBDF("HT"):IBDF("HT"),1:"")
+34 SET X=$$SETSTR^VALM1($JUSTIFY(IBDVAL,3),X,66,3)
DO TMP
End DoDot:2
End DoDot:1
+35 QUIT
TMP ; -- Set up Array
+1 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET ^TMP("FORMOBJ",$JOB,IBDCNT,0)=X
SET ^TMP("FORMOBJ",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+3 SET ^TMP("FORMIDX",$JOB,IBDCNT)=VALMCNT_"^"_IBDFIFN_"^"_IBDF("BLK")
+4 QUIT
+5 ;
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
+4 ;
EXIT ; -- exit code
+1 KILL IBDCAT,IBDNME,IBDTYPE,VALMCNT,IBDCNT,IBDCNT1,IBDNAME,IBDNUM,IBDNME,IBDFIFN,IBDVAL,IBDNODE,IBFASTXT,IBDF,IBBLOCK,IBDFNODE,IBDFSNOD,IBDFOBJ,IBDOBJ1,IBQUIT,IBDFFLAG,IBDOBJ
+2 KILL ^TMP("FORM-OBJ",$JOB),^TMP("FORMIDX",$JOB),^TMP("FORMOBJ",$JOB)
+3 QUIT
+4 ;
NUL ; -- NULL MESSAGE
+1 SET ^TMP("FORMOBJ",$JOB,1,0)=" "
SET ^TMP("FORMOBJ",$JOB,2,0)="There are no Components listed for this form."
SET ^TMP("FORMIDX",$JOB,1)=1
SET ^TMP("FORMIDX",$JOB,2)=2
+2 QUIT
+3 ;
HDR ; -- print patient header
+1 ;Q:'$D(IBDFIFN)
+2 SET X=" Form Name: "_$EXTRACT($PIECE($GET(^IBE(357,+IBDFIFN,0)),"^"),1,25)
+3 SET IBDVAL="FORM ID #: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",13):$PIECE(^IBE(357,+IBDFIFN,0),"^",13),1:"")
+4 SET VALMHDR(1)=$$SETSTR^VALM1(IBDVAL,X,55,25)
+5 SET X=" Status: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",5):"Compiled",1:"Uncompiled")
+6 SET IBDVAL=" Toolkit: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",7):"Yes",1:"No")
+7 SET VALMHDR(2)=$$SETSTR^VALM1(IBDVAL,X,55,25)
+8 SET X=" Scannable: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",12):"Yes",1:"No")
+9 SET IBDVAL=" Use ICR: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",6):"Yes",1:"No")
+10 SET VALMHDR(3)=$$SETSTR^VALM1(IBDVAL,X,55,25)
+11 SET X=+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",2)
+12 SET X="Simplex/Duplex: "_$SELECT(X]""&(X=0):"Simplex",X]""&(X=1):"Duplex Long-Edge",X]""&(X=2):"Duplex Short-Edge",1:"")
+13 SET IBDVAL=" # Pages: "_$SELECT(+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",11):+$PIECE($GET(^IBE(357,+IBDFIFN,0)),"^",11),1:"0")
+14 SET VALMHDR(4)=$$SETSTR^VALM1(IBDVAL,X,55,25)
+15 QUIT
+16 ;
END IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 KILL I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK,IBDFIFN
+2 KILL ^TMP("FORMIDX",$JOB),^TMP("FORM-OBJ",$JOB),^TMP("FORMOBJ",$JOB)
+3 DO ^%ZISC
+4 QUIT
+5 ;
EXP ; -- Expand Action
+1 DO FULL^VALM1
+2 NEW VALMI,VALMAT,VALMY
+3 DO EN^VALM2(XQORNOD(0),"O")
SET VALMI=0
+4 FOR
SET VALMI=$ORDER(VALMY(VALMI))
if 'VALMI
QUIT
Begin DoDot:1
+5 SET VALMAT=$GET(IBBLOCK(VALMI))
+6 WRITE !
+7 IF DUZ(0)="@"
WRITE !,"Entry No. ",+$PIECE(VALMAT,"^",11)
+8 SET DA=+$PIECE(VALMAT,U,11)
SET DIC="^IBE(357.1,"
SET DR="0"
DO EN^DIQ
DO PAUSE^VALM1
+9 KILL DA,DIC,DR
End DoDot:1
+10 SET VALMBCK="R"
+11 QUIT
