IBDFFSMP ;ALB/MAF -- Print a sample of all encounter forms. - Dec 12 1995@800
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
S (IBDFFLG,IBQUIT)=0
S (IBPM,WITHDATA)=1
K ^TMP("IBFRMS",$J)
;
; -- Ask patient name
D PATIENT G:IBQUIT EXIT
;
; -- Loop thru Print Manager Clinic Setup to find active forms used by
; clinics.
S IBCLINIC="" F S IBCLINIC=$O(^SD(409.95,"B",IBCLINIC)) Q:IBCLINIC']"" D
.S SETUP=$O(^SD(409.95,"B",IBCLINIC,""))
.S NAME=$P($G(^SC(IBCLINIC,0)),"^")
.D SET
I '$D(^TMP("IBFRMS",$J)) W !!,"There are no forms set up for clinics...",!! G EXIT
D NOW^IBDF1A,DEVICE ;sets IBAPPT to NOW
G:IBQUIT EXIT
I 'IBDFFLG U IO D QUEUED
G EXIT
;
SET ; -- Build list into array IBFORMS. Make sure EF is one that is active
; Will print form only once.
I $O(^SD(409.95,"B",IBCLINIC,0)) D
.S IBDFNODE=^SD(409.95,SETUP,0)
.S IBQUIT=0
.F X=2,3,4,5,6,8,9 S:$P(IBDFNODE,"^",X)&('$D(^TMP("IBFRMS",$J,+$P(IBDFNODE,"^",X)))) ^TMP("IBFRMS",$J,$P(IBDFNODE,"^",X))=IBCLINIC ;Loop thru the clinic setup node to find the active EF.
.Q
Q
;
PATIENT ; -- gets the patient to print the form for
W !!
S DIR(0)="P^2:EM",DIR("A")="Select PATIENT NAME for Samples" D ^DIR K DIR I $D(DIRUT)!(+Y<1)!('(+Y)) S IBQUIT=1 Q
S DFN=+Y
Q
;
QUEUED ;
;input - DFN,IBAPPT,IBCLINIC
N IBDEVICE
;
D DEVICE^IBDFUA(0,.IBDEVICE)
S IBDSAMP=1 ;printing sample forms don't update forms tracking, print form in name/ssn block
F IBFORM=0:0 S IBFORM=$O(^TMP("IBFRMS",$J,IBFORM)) Q:'IBFORM D
.S IBCLINIC=+$G(^TMP("IBFRMS",$J,IBFORM))
.D DRWFORM^IBDF2A(IBFORM,WITHDATA,.IBDEVICE)
;
EXIT ;
K IBDSAMP
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K ^TMP("IBFRMS",$J)
D KPRNTVAR^IBDFUA ;kills the screen and graphics parameters
K CLINIC,DFN,FORMS,IBAPPT,IBCLINIC,IBFORM,IBDFNODE,IBDFFLG,IBPM,IBQUIT,NAME,POP,SETUP,WITHDATA,X,Y,I
Q
;
DEVICE ;
I $D(ZTQUEUED) Q
W !,$C(7),"** Encounter Forms require a page size of 80 lines and 132 columns. **"
K %IS,%ZIS,IOP S %ZIS="MQ" D ^%ZIS I POP S IBQUIT=1 Q
I $D(IO("Q")) D
.S ZTRTN="QUEUED^IBDFFSMP",(ZTSAVE("WITHDATA"),ZTSAVE("IB*"),ZTSAVE("DFN"),ZTSAVE("FORMS"))="",ZTSAVE("^TMP(""IBFRMS"",$J,")=""
.S ZTDESC="IBD - PRINT SAMPLE ENCOUNTER FORM" D ^%ZTLOAD
.W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
.I $D(ZTSK) S IBDFFLG=1
.D HOME^%ZIS S IBQUIT=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFFSMP 2410 printed Dec 13, 2024@02:52:32 Page 2
IBDFFSMP ;ALB/MAF -- Print a sample of all encounter forms. - Dec 12 1995@800
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 SET (IBDFFLG,IBQUIT)=0
+4 SET (IBPM,WITHDATA)=1
+5 KILL ^TMP("IBFRMS",$JOB)
+6 ;
+7 ; -- Ask patient name
+8 DO PATIENT
if IBQUIT
GOTO EXIT
+9 ;
+10 ; -- Loop thru Print Manager Clinic Setup to find active forms used by
+11 ; clinics.
+12 SET IBCLINIC=""
FOR
SET IBCLINIC=$ORDER(^SD(409.95,"B",IBCLINIC))
if IBCLINIC']""
QUIT
Begin DoDot:1
+13 SET SETUP=$ORDER(^SD(409.95,"B",IBCLINIC,""))
+14 SET NAME=$PIECE($GET(^SC(IBCLINIC,0)),"^")
+15 DO SET
End DoDot:1
+16 IF '$DATA(^TMP("IBFRMS",$JOB))
WRITE !!,"There are no forms set up for clinics...",!!
GOTO EXIT
+17 ;sets IBAPPT to NOW
DO NOW^IBDF1A
DO DEVICE
+18 if IBQUIT
GOTO EXIT
+19 IF 'IBDFFLG
USE IO
DO QUEUED
+20 GOTO EXIT
+21 ;
SET ; -- Build list into array IBFORMS. Make sure EF is one that is active
+1 ; Will print form only once.
+2 IF $ORDER(^SD(409.95,"B",IBCLINIC,0))
Begin DoDot:1
+3 SET IBDFNODE=^SD(409.95,SETUP,0)
+4 SET IBQUIT=0
+5 ;Loop thru the clinic setup node to find the active EF.
FOR X=2,3,4,5,6,8,9
if $PIECE(IBDFNODE,"^",X)&('$DATA(^TMP("IBFRMS",$JOB,+$PIECE(IBDFNODE,"^",X))))
SET ^TMP("IBFRMS",$JOB,$PIECE(IBDFNODE,"^",X))=IBCLINIC
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
PATIENT ; -- gets the patient to print the form for
+1 WRITE !!
+2 SET DIR(0)="P^2:EM"
SET DIR("A")="Select PATIENT NAME for Samples"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(+Y<1)!('(+Y))
SET IBQUIT=1
QUIT
+3 SET DFN=+Y
+4 QUIT
+5 ;
QUEUED ;
+1 ;input - DFN,IBAPPT,IBCLINIC
+2 NEW IBDEVICE
+3 ;
+4 DO DEVICE^IBDFUA(0,.IBDEVICE)
+5 ;printing sample forms don't update forms tracking, print form in name/ssn block
SET IBDSAMP=1
+6 FOR IBFORM=0:0
SET IBFORM=$ORDER(^TMP("IBFRMS",$JOB,IBFORM))
if 'IBFORM
QUIT
Begin DoDot:1
+7 SET IBCLINIC=+$GET(^TMP("IBFRMS",$JOB,IBFORM))
+8 DO DRWFORM^IBDF2A(IBFORM,WITHDATA,.IBDEVICE)
End DoDot:1
+9 ;
EXIT ;
+1 KILL IBDSAMP
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 KILL ^TMP("IBFRMS",$JOB)
+5 ;kills the screen and graphics parameters
DO KPRNTVAR^IBDFUA
+6 KILL CLINIC,DFN,FORMS,IBAPPT,IBCLINIC,IBFORM,IBDFNODE,IBDFFLG,IBPM,IBQUIT,NAME,POP,SETUP,WITHDATA,X,Y,I
+7 QUIT
+8 ;
DEVICE ;
+1 IF $DATA(ZTQUEUED)
QUIT
+2 WRITE !,$CHAR(7),"** Encounter Forms require a page size of 80 lines and 132 columns. **"
+3 KILL %IS,%ZIS,IOP
SET %ZIS="MQ"
DO ^%ZIS
IF POP
SET IBQUIT=1
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="QUEUED^IBDFFSMP"
SET (ZTSAVE("WITHDATA"),ZTSAVE("IB*"),ZTSAVE("DFN"),ZTSAVE("FORMS"))=""
SET ZTSAVE("^TMP(""IBFRMS"",$J,")=""
+6 SET ZTDESC="IBD - PRINT SAMPLE ENCOUNTER FORM"
DO ^%ZTLOAD
+7 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+8 IF $DATA(ZTSK)
SET IBDFFLG=1
+9 DO HOME^%ZIS
SET IBQUIT=1
QUIT
End DoDot:1
+10 QUIT
