IBDFFV3.m

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 ---IBDFFV3   4036     printed  Mar 13, 2025@21:57:43                                                                                                                                                                                                     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:.............