IBDFFV3 ;;ALB/CMR - AICS FORM VALIDATION ; FEB 23, 1996
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
PRINT(FRM,NAME,TYPE,CL,DG) ; -- print validation for each form
; -- FRM = ien file 357
; -- NAME (optional) name of form
; -- TYPE (optional) type of form where:
; -- 1 = FORM
; -- 2 = BASIC DEFAULT FORM
; -- 3 = SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS
; -- 4 = SUPPLEMENTAL FORM - FIRST TIME PATIENT
; -- 5 = FORM WITH NO PRE-PRINTED PATIENT DATA
; -- 6 = SUPPLEMENTAL FORM - ALL PATIENTS
; -- 7 = RESERVED FOR FUTURE USE
; -- 8 = SUPPLEMENTAL FORM - ALL PATIENTS
; -- 9 = SUPPLEMENTAL FORM - ALL PATIENTS
; -- CL (optional) clinic header
; -- DG (optional) group or division header
N IEN,BUB,NODE,PG,IBDFFVAL,IBID,IBLABEL,PI,CK,CODE,GROUP
K WRITE
Q:'FRM!($G(^IBE(357,FRM,0))']"")
S PG=0
I $G(NAME)']"" S NAME=$P(^IBE(357,FRM,0),U)
I '$G(TYPE) S TYPE=1
S IEN=$P(^IBE(357,FRM,0),U,13) Q:'IEN!('$D(^IBD(357.95,+IEN)))
W $$CJ^XLFSTR("ENCOUNTER FORM VALIDATION",IOM),!
I $G(DG)]"" W !,DG
I $G(CL)]"" W !,CL
W !,$P($T(TYPE+TYPE),";;",2)," ",NAME
K BUB,HP
; -- $o through all bubbles
S BUB=0,GROUP="" F S BUB=$O(^IBD(357.95,IEN,1,BUB)) Q:'BUB!($G(IBDFOUT)) S NODE=$G(^IBD(357.95,IEN,1,BUB,0)) I NODE]"" D DISP
K BUB
S HP=0 F S HP=$O(^IBD(357.95,IEN,2,HP)) Q:'HP!($G(IBDFOUT)) S NODE=$G(^IBD(357.95,IEN,2,HP,0)) I NODE]"" D DISP
Q:$G(IBDFOUT)
D PAGE(100) ;force final page footers
Q
DISP ; -- display data for each element
N IBINACT
N ERR
; -- write out group subheader if different from previous
I GROUP'=$P(NODE,U,5) S GROUP=$P(NODE,U,5) D PAGE(8) Q:$G(IBDFOUT) I '$G(CK) W !!,GROUP,!
; -- determine errors up front
S PI=$S($D(BUB):$P(NODE,U,3),$D(HP):$P(NODE,U,4),1:"") I 'PI S ERR("PI")=""
S DQ=$P(NODE,U,10) I 'DQ,$P($G(^IBE(357.6,+PI,0)),U,19) S ERR("DQ")=""
K IBID,IBLABEL,IBINACT
I $D(BUB) S X=$P(NODE,U,4) I X,PI X $G(^IBE(357.6,PI,19)) I $G(IBLABEL)']"" S ERR("CODE")=""
I $G(IBINACT) S ERR("INACT")=""
D PAGE(5) Q:$G(IBDFOUT)
; -- write error flag followed by displayed text
W ! W:$D(ERR) "*" W ?2,"[ ] ",$S($D(BUB):$P(NODE,U,8),$D(HP):$P(NODE,U,9),1:"") S WRITE=1
; -- if bubble is dynamic s code accordingly
I $D(BUB),($G(IBID)']""),($P(NODE,U,11)) S IBID="DYNAMIC",IBLABEL="Value determined at print time"
I $D(HP) S IBID="HAND PRINT",IBLABEL="Value determined at scan time"
; -- write return values
I $G(IBID)]"" W !,?6,IBID,?22,$G(IBLABEL)
; -- write data qualifiers
I DQ]"" W !?6,"DATA QUALIFIER",?22,$P($G(^IBD(357.98,DQ,0)),"^")
I $D(HP),($P(NODE,U,17)) W !?6,"DATA ELEMENT",?22,$P($G(^IBE(359.1,$P(NODE,U,17),0)),U)
; -- process errors
I $D(ERR) D ERROR
Q
ERROR ;gathers errors to write
I '$D(ERR) Q
N CNT
I $D(ERR("PI")) D ERRORS("*** Package Interface is missing ***")
I $D(ERR("DQ")) D ERRORS("*** Data Qualifier is missing ***")
I $D(ERR("CODE")) D ERRORS("*** Invalid "_GROUP_" ***")
I $D(ERR("INACT")) D ERRORS("*** Inactive "_GROUP_" ***")
Q
ERRORS(ERR) ; -- writes out errors
I $G(CNT) W !
I '$G(CNT) W !?6,"ERRORS" S CNT=1
W ?22,ERR
Q
PAGE(PL) ; -- check page length
; -- adds two lines to account for footer
K CK
I +PL S PL=PL+2
I '+PL S PL=5
Q:$Y+PL<IOSL
S PG=PG+1,CK=1
W !!,$$CJ^XLFSTR(PG,IOM)
I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR,DIRUT,DUOUT,DTOUT I 'Y S IBDFOUT=1 Q
W @IOF
I +PL<100 D
.W !,$$CJ^XLFSTR("ENCOUNTER FORM VALIDATION",IOM)
.W !!,$P($T(TYPE+TYPE),";;",2)," ",NAME
.W !!,GROUP,!
Q
TYPE ; -- list of form types
;;FORM:.........................................
;;BASIC DEFAULT FORM: .........................
;;SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS:
;;SUPPLEMENTAL FORM - FIRST TIME PATIENT: .....
;;FORM WITH NO PRE-PRINTED PATIENT DATA: ......
;;SUPPLEMENTAL FORM - ALL PATIENTS: ...........
;;RESERVED FOR FUTURE USE: ....................
;;SUPPLEMENTAL FORM - ALL PATIENTS:.............
;;SUPPLEMENTAL FORM - ALL PATIENTS:.............
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFFV3 4036 printed Dec 13, 2024@02:52:40 Page 2
IBDFFV3 ;;ALB/CMR - AICS FORM VALIDATION ; FEB 23, 1996
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
PRINT(FRM,NAME,TYPE,CL,DG) ; -- print validation for each form
+1 ; -- FRM = ien file 357
+2 ; -- NAME (optional) name of form
+3 ; -- TYPE (optional) type of form where:
+4 ; -- 1 = FORM
+5 ; -- 2 = BASIC DEFAULT FORM
+6 ; -- 3 = SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS
+7 ; -- 4 = SUPPLEMENTAL FORM - FIRST TIME PATIENT
+8 ; -- 5 = FORM WITH NO PRE-PRINTED PATIENT DATA
+9 ; -- 6 = SUPPLEMENTAL FORM - ALL PATIENTS
+10 ; -- 7 = RESERVED FOR FUTURE USE
+11 ; -- 8 = SUPPLEMENTAL FORM - ALL PATIENTS
+12 ; -- 9 = SUPPLEMENTAL FORM - ALL PATIENTS
+13 ; -- CL (optional) clinic header
+14 ; -- DG (optional) group or division header
+15 NEW IEN,BUB,NODE,PG,IBDFFVAL,IBID,IBLABEL,PI,CK,CODE,GROUP
+16 KILL WRITE
+17 if 'FRM!($GET(^IBE(357,FRM,0))']"")
QUIT
+18 SET PG=0
+19 IF $GET(NAME)']""
SET NAME=$PIECE(^IBE(357,FRM,0),U)
+20 IF '$GET(TYPE)
SET TYPE=1
+21 SET IEN=$PIECE(^IBE(357,FRM,0),U,13)
if 'IEN!('$DATA(^IBD(357.95,+IEN)))
QUIT
+22 WRITE $$CJ^XLFSTR("ENCOUNTER FORM VALIDATION",IOM),!
+23 IF $GET(DG)]""
WRITE !,DG
+24 IF $GET(CL)]""
WRITE !,CL
+25 WRITE !,$PIECE($TEXT(TYPE+TYPE),";;",2)," ",NAME
+26 KILL BUB,HP
+27 ; -- $o through all bubbles
+28 SET BUB=0
SET GROUP=""
FOR
SET BUB=$ORDER(^IBD(357.95,IEN,1,BUB))
if 'BUB!($GET(IBDFOUT))
QUIT
SET NODE=$GET(^IBD(357.95,IEN,1,BUB,0))
IF NODE]""
DO DISP
+29 KILL BUB
+30 SET HP=0
FOR
SET HP=$ORDER(^IBD(357.95,IEN,2,HP))
if 'HP!($GET(IBDFOUT))
QUIT
SET NODE=$GET(^IBD(357.95,IEN,2,HP,0))
IF NODE]""
DO DISP
+31 if $GET(IBDFOUT)
QUIT
+32 ;force final page footers
DO PAGE(100)
+33 QUIT
DISP ; -- display data for each element
+1 NEW IBINACT
+2 NEW ERR
+3 ; -- write out group subheader if different from previous
+4 IF GROUP'=$PIECE(NODE,U,5)
SET GROUP=$PIECE(NODE,U,5)
DO PAGE(8)
if $GET(IBDFOUT)
QUIT
IF '$GET(CK)
WRITE !!,GROUP,!
+5 ; -- determine errors up front
+6 SET PI=$SELECT($DATA(BUB):$PIECE(NODE,U,3),$DATA(HP):$PIECE(NODE,U,4),1:"")
IF 'PI
SET ERR("PI")=""
+7 SET DQ=$PIECE(NODE,U,10)
IF 'DQ
IF $PIECE($GET(^IBE(357.6,+PI,0)),U,19)
SET ERR("DQ")=""
+8 KILL IBID,IBLABEL,IBINACT
+9 IF $DATA(BUB)
SET X=$PIECE(NODE,U,4)
IF X
IF PI
XECUTE $GET(^IBE(357.6,PI,19))
IF $GET(IBLABEL)']""
SET ERR("CODE")=""
+10 IF $GET(IBINACT)
SET ERR("INACT")=""
+11 DO PAGE(5)
if $GET(IBDFOUT)
QUIT
+12 ; -- write error flag followed by displayed text
+13 WRITE !
if $DATA(ERR)
WRITE "*"
WRITE ?2,"[ ] ",$SELECT($DATA(BUB):$PIECE(NODE,U,8),$DATA(HP):$PIECE(NODE,U,9),1:"")
SET WRITE=1
+14 ; -- if bubble is dynamic s code accordingly
+15 IF $DATA(BUB)
IF ($GET(IBID)']"")
IF ($PIECE(NODE,U,11))
SET IBID="DYNAMIC"
SET IBLABEL="Value determined at print time"
+16 IF $DATA(HP)
SET IBID="HAND PRINT"
SET IBLABEL="Value determined at scan time"
+17 ; -- write return values
+18 IF $GET(IBID)]""
WRITE !,?6,IBID,?22,$GET(IBLABEL)
+19 ; -- write data qualifiers
+20 IF DQ]""
WRITE !?6,"DATA QUALIFIER",?22,$PIECE($GET(^IBD(357.98,DQ,0)),"^")
+21 IF $DATA(HP)
IF ($PIECE(NODE,U,17))
WRITE !?6,"DATA ELEMENT",?22,$PIECE($GET(^IBE(359.1,$PIECE(NODE,U,17),0)),U)
+22 ; -- process errors
+23 IF $DATA(ERR)
DO ERROR
+24 QUIT
ERROR ;gathers errors to write
+1 IF '$DATA(ERR)
QUIT
+2 NEW CNT
+3 IF $DATA(ERR("PI"))
DO ERRORS("*** Package Interface is missing ***")
+4 IF $DATA(ERR("DQ"))
DO ERRORS("*** Data Qualifier is missing ***")
+5 IF $DATA(ERR("CODE"))
DO ERRORS("*** Invalid "_GROUP_" ***")
+6 IF $DATA(ERR("INACT"))
DO ERRORS("*** Inactive "_GROUP_" ***")
+7 QUIT
ERRORS(ERR) ; -- writes out errors
+1 IF $GET(CNT)
WRITE !
+2 IF '$GET(CNT)
WRITE !?6,"ERRORS"
SET CNT=1
+3 WRITE ?22,ERR
+4 QUIT
PAGE(PL) ; -- check page length
+1 ; -- adds two lines to account for footer
+2 KILL CK
+3 IF +PL
SET PL=PL+2
+4 IF '+PL
SET PL=5
+5 if $Y+PL<IOSL
QUIT
+6 SET PG=PG+1
SET CK=1
+7 WRITE !!,$$CJ^XLFSTR(PG,IOM)
+8 IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT,DUOUT,DTOUT
IF 'Y
SET IBDFOUT=1
QUIT
+9 WRITE @IOF
+10 IF +PL<100
Begin DoDot:1
+11 WRITE !,$$CJ^XLFSTR("ENCOUNTER FORM VALIDATION",IOM)
+12 WRITE !!,$PIECE($TEXT(TYPE+TYPE),";;",2)," ",NAME
+13 WRITE !!,GROUP,!
End DoDot:1
+14 QUIT
TYPE ; -- list of form types
+1 ;;FORM:.........................................
+2 ;;BASIC DEFAULT FORM: .........................
+3 ;;SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS:
+4 ;;SUPPLEMENTAL FORM - FIRST TIME PATIENT: .....
+5 ;;FORM WITH NO PRE-PRINTED PATIENT DATA: ......
+6 ;;SUPPLEMENTAL FORM - ALL PATIENTS: ...........
+7 ;;RESERVED FOR FUTURE USE: ....................
+8 ;;SUPPLEMENTAL FORM - ALL PATIENTS:.............
+9 ;;SUPPLEMENTAL FORM - ALL PATIENTS:.............
