- 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 Feb 19, 2025@00:18:57 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
