Routine: IBDF1C

IBDF1C ;ALB/CJM - ENCOUNTER FORM (print sample form) ; FEB 11,1992

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**42**;APR 24, 1997

 ;This print routine forces queueing - so that allocation problems do not occur.

PRINT(IBFORM) ;

 N IBQUIT,NODE,HT,WD S IBQUIT=0

 D FULL^VALM1

 S VALMBCK="R"

 I ('$G(IBFORM))!$G(IBTKBLK) N IBFORM D FORM G:IBQUIT EXIT

 I $G(IBFORM) S NODE=$G(^IBE(357,IBFORM,0)),WD=$P(NODE,"^",9),HT=$P(NODE,"^",10) K NODE

 D DEVICE,HOME^%ZIS G EXIT

QUEUED ; entry

 D FORM^IBDF2A(IBFORM,0)

 I $D(ZTQUEUED) S ZTREQ="@"

EXIT ;

 K ZTSK,Y,X,J,D0,%,%I,D,DIC,DY,DX,I

DEVICE ;

 W !,"** You must queue the form to print. **"

 W !,$C(7),"** This Encounter Form requires "_WD_" columns and a page length of "_HT_" lines. **",!

 ;queuing is automatic - the device is not opened

 K %IS,%ZIS,IOP S %ZIS="N0Q",%ZIS("A")="Printer to queue to: ",%ZIS("B")="",%ZIS("S")="I $E($P($G(^%ZIS(2,+$G(^%ZIS(1,Y,""SUBTYPE"")),0)),U),1,2)=""P-""" D ^%ZIS

 Q:POP

 I $D(IO("S")) D  G DEVICE

 .W !!,"** Printer can not be a slave printer please try again.**",!

 S ZTRTN="QUEUED^IBDF1C",ZTSAVE("IBFORM")="",ZTDESC="ENCOUNTER FORM",ZTDTH=$H D ^%ZTLOAD W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")

FORM ;returns IBFORM

 N P4

 S IBFORM=0

 ;if the user used the '=' syntax then assume he wants to choose from the list

 S P4=$P(XQORNOD(0),"^",4)

 I P4["==" S P4=$P(P4,"==")_"="_$P(P4,"==",2),$P(XQORNOD(0),"^",4)=P4

 I $G(VALM("TITLE"))["FORMS",$P(P4,"=",2) D

 .I $G(IBAPI("SELECT"))'="" X IBAPI("SELECT")

 .S:IBFORM Y(0)=$G(^IBE(357,IBFORM,0))

 E  D

 .K DIR S DIR(0)="YA",DIR("A")="Do you want to print a form from the toolkit? "

 .D ^DIR K DIR Q:(Y=-1)!($D(DIRUT))

 .K DIC S DIC("S")=$S(Y:"I $P(^(0),U,7),$P(^(0),U)'=""WORKCOPY"",$P(^(0),U)'=""TOOL KIT""",1:"I '$P(^(0),U,7)"),DIC=357,DIC(0)="AEQZ",DIC("A")="Select any FORM by name: "

 .D ^DIC K DIC Q:$D(DIRUT)!(Y<0)

 .S IBFORM=+Y

 I 'IBFORM S IBQUIT=1 Q

 S WD=$P($G(Y(0)),"^",9),HT=$P($G(Y(0)),"^",10)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1C   2035     printed  Feb 19, 2025@00:17:36                                                                                                                                                                                                      Page 2

IBDF1C    ;ALB/CJM - ENCOUNTER FORM (print sample form) ; FEB 11,1992

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**42**;APR 24, 1997

 +2       ;

 +3       ;This print routine forces queueing - so that allocation problems do not occur.

 +4       ;

PRINT(IBFORM) ;

 +1        NEW IBQUIT,NODE,HT,WD

           SET IBQUIT=0

 +2        DO FULL^VALM1

 +3        SET VALMBCK="R"

 +4       ;

 +5        IF ('$GET(IBFORM))!$GET(IBTKBLK)

               NEW IBFORM

               DO FORM

               if IBQUIT

                   GOTO EXIT

 +6        IF $GET(IBFORM)

               SET NODE=$GET(^IBE(357,IBFORM,0))

               SET WD=$PIECE(NODE,"^",9)

               SET HT=$PIECE(NODE,"^",10)

               KILL NODE

 +7        DO DEVICE

           DO HOME^%ZIS

           GOTO EXIT

 +8       ;

QUEUED    ; entry

 +1        DO FORM^IBDF2A(IBFORM,0)

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3       ;

EXIT      ;

 +1        KILL ZTSK,Y,X,J,D0,%,%I,D,DIC,DY,DX,I

 +2        QUIT

 +3       ;

DEVICE    ;

 +1        WRITE !,"** You must queue the form to print. **"

 +2        WRITE !,$CHAR(7),"** This Encounter Form requires "_WD_" columns and a page length of "_HT_" lines. **",!

 +3       ;

 +4       ;queuing is automatic - the device is not opened

 +5        KILL %IS,%ZIS,IOP

           SET %ZIS="N0Q"

           SET %ZIS("A")="Printer to queue to: "

           SET %ZIS("B")=""

           SET %ZIS("S")="I $E($P($G(^%ZIS(2,+$G(^%ZIS(1,Y,""SUBTYPE"")),0)),U),1,2)=""P-"""

           DO ^%ZIS

 +6        if POP

               QUIT

 +7        IF $DATA(IO("S"))

               Begin DoDot:1

 +8                WRITE !!,"** Printer can not be a slave printer please try again.**",!

               End DoDot:1

               GOTO DEVICE

 +9        SET ZTRTN="QUEUED^IBDF1C"

           SET ZTSAVE("IBFORM")=""

           SET ZTDESC="ENCOUNTER FORM"

           SET ZTDTH=$HOROLOG

           DO ^%ZTLOAD

           WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")

 +10       QUIT

 +11      ;

FORM      ;returns IBFORM

 +1        NEW P4

 +2        SET IBFORM=0

 +3       ;if the user used the '=' syntax then assume he wants to choose from the list

 +4        SET P4=$PIECE(XQORNOD(0),"^",4)

 +5        IF P4["=="

               SET P4=$PIECE(P4,"==")_"="_$PIECE(P4,"==",2)

               SET $PIECE(XQORNOD(0),"^",4)=P4

 +6        IF $GET(VALM("TITLE"))["FORMS"

               IF $PIECE(P4,"=",2)

                   Begin DoDot:1

 +7                    IF $GET(IBAPI("SELECT"))'=""

                           XECUTE IBAPI("SELECT")

 +8                    if IBFORM

                           SET Y(0)=$GET(^IBE(357,IBFORM,0))

                   End DoDot:1

 +9       IF '$TEST

               Begin DoDot:1

 +10               KILL DIR

                   SET DIR(0)="YA"

                   SET DIR("A")="Do you want to print a form from the toolkit? "

 +11               DO ^DIR

                   KILL DIR

                   if (Y=-1)!($DATA(DIRUT))

                       QUIT

 +12               KILL DIC

                   SET DIC("S")=$SELECT(Y:"I $P(^(0),U,7),$P(^(0),U)'=""WORKCOPY"",$P(^(0),U)'=""TOOL KIT""",1:"I '$P(^(0),U,7)")

                   SET DIC=357

                   SET DIC(0)="AEQZ"

                   SET DIC("A")="Select any FORM by name: "

 +13               DO ^DIC

                   KILL DIC

                   if $DATA(DIRUT)!(Y<0)

                       QUIT

 +14               SET IBFORM=+Y

               End DoDot:1

 +15       IF 'IBFORM

               SET IBQUIT=1

               QUIT

 +16       SET WD=$PIECE($GET(Y(0)),"^",9)

           SET HT=$PIECE($GET(Y(0)),"^",10)

 +17       QUIT

IBDF1C.m