- IBDF1BA ;ALB/CJM - ENCOUNTER FORM (user options for printing - continuation of IBDF1B); 3/1/93
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**25,34**;APR 24, 1997
- ;
- TERMSTRT ;get terminal digit to restart from - OUTPUT=IBREPRNT
- S IBREPRNT="",DIR(0)="F^4:5",DIR("A")="ENTER THE LAST 4 DIGITS OF THE SSN TO BEGIN REPRINT FROM",DIR("?")="ENTER THE LAST FOUR DIGITS OF THE SSN OF THE LAST PATIENT FOR WHOM FORMS WERE PRINTED"
- F D ^DIR Q:$D(DIRUT)!(Y=-1) D Q:IBREPRNT'=""
- .I Y'?4N W !,$C(7),"MUST BE 4 NUMBERS!" Q
- .S IBREPRNT=Y,IBREPRNT=+($E(IBREPRNT,3,4)_$E(IBREPRNT,1,2))
- K DIR
- Q
- CLNCSTRT ;get clinic and division to restart from,OUTPUT=IBREPRNT (name of clinic) and IBSTRTDV (division to restart from)
- ;
- N NODE
- S IBREPRNT=""
- S DIR(0)="409.95,.01",DIR("A")="ENTER CLINIC TO BEGIN REPRINT FROM",DIR("?")="ENTER THE LAST CLINIC FOR WHICH ANY FORMS WERE PRINTED"
- D ^DIR K DIR I $D(DIRUT)!(+Y<0) Q
- S NODE=$G(^SC(+Y,0))
- S IBREPRNT=$P(NODE,"^")
- S IBSTRTDV=+$P(NODE,"^",15) I IBSTRTDV S IBSTRTDV=$P($G(^DG(40.8,IBSTRTDV,0)),"^")
- Q
- ;
- SEARCH ;get the appointment data on a patient, put in IBTMP array, indexed by appointment
- ;screens out any appts in clinics with nothing defined to print
- N IBX,IBLN,CLINIC,APPT
- S (VASD("F"),VASD("T"))=IBDT,VASD("W")=129 D SDA^VADPT Q:(VAERR!'$D(^UTILITY("VASD",$J)))
- S IBX="" F S IBX=$O(^UTILITY("VASD",$J,IBX)) Q:IBX="" D
- . S IBLN=^UTILITY("VASD",$J,IBX,"I"),APPT=+$P(IBLN,"^"),CLINIC=$P(IBLN,"^",2)
- .Q:'APPT!'CLINIC
- .Q:'($D(^SD(409.95,"B",CLINIC))!$D(^SD(409.96,"B",+$$DIVISION^IBDF1B5(CLINIC))))
- .;^UTILITY("VASD",$J,IBX,"E")=(EXTERNAL FORMAT) appt date time^clinic name^status^appt type
- .S IBTMP(APPT)=DFN_"^"_CLINIC_"^"_IBNM_"^"_^UTILITY("VASD",$J,IBX,"E")
- K VASD,VAERR,^UTILITY("VASD",$J)
- Q
- ;
- DISP ;display patients/clinics appointments found and get users choice
- ;sort type is by clinic,patient
- N CLNCIEN,CLNCNAME
- I '$D(IBTMP) W !!,?5,"No Active Appointments for ",IBNM," on",!,"this date in any clinic or division that has forms or reports defined to print",! G ENDDISP
- I '$D(IBTMP) W !!,?10,"No Active Appointments in a Clinic with an Encounter Form",!,?10,"for ",IBNM," on this date.",! G ENDDISP
- W !!,"Appointments for ",IBNM,!
- S IBX="" F IBI=1:1 S IBX=$O(IBTMP(IBX)) Q:IBX="" S IBLN=IBTMP(IBX) W !,$J(IBI,3)," ",$E($P(IBLN,"^",5),1,20),?25," " F IBJ=4,6,7 W " ",$P(IBLN,"^",IBJ)
- S DIR(0)="LO^1:"_(IBI-1),DIR("A")=" Select Appointments" D ^DIR K DIR G:$D(DIRUT) ENDDISP
- S IBX="" F IBI=1:1 S IBX=$O(IBTMP(IBX)) Q:IBX="" I Y[(IBI_",") D
- .S CLNCIEN=$P(IBTMP(IBX),"^",2),CLNCNAME=$P(IBTMP(IBX),"^",5)
- .;
- .;list format - ^TMP("IBDF",$J,"P"," ",division name(but set it to " " because for selecting single appts sort by division not needed),clinic name,clinic ien,patient name,dfn,appt)=""
- .;S ^TMP("IBDF",$J,"P"," ",CLNCNAME,CLNCIEN,IBNM,DFN,IBX)=""
- .S ^TMP("IBDF",$J,"P"," ",$E(CLNCNAME,1,25),CLNCIEN,$E(IBNM,1,25),DFN,IBX)=""
- .;also keep an index by ...,"APPT LIST",DFN,APPT)
- .S ^TMP("IBDF",$J,"APPT LIST",DFN,IBX)=""
- ENDDISP K IBTMP,IBX,IBI,IBJ,IBLN,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,^UTILITY("VASD",$J)
- Q
- ;
- STARTDIV() ;asks what division to restart the job from and returns division name, or "" if user declines
- N IBDIV
- K DIC S DIC="^DG(40.8,",DIC(0)="AEQMN",DIC("A")="SELECT THE DIVISION TO START THE REPRINT FROM: "
- S IBDIV=$O(^DG(40.8,0)) S:IBDIV DIC("B")=$P($G(^DG(40.8,IBDIV,0)),"^")
- D ^DIC K DIC
- I (+Y<0)!$D(DTOUT)!$D(DUOUT) Q ""
- Q $P(Y,"^",2)
- SORTBY ;sort by clinic/patient, clinic/terminal digit, or terminal digit?
- K DIR S DIR(0)="S^1:Division/Clinic/Patient Name;2:Division/Terminal Digits;3:Division/Clinic/Terminal Digits"
- S DIR("?")="Enter '1' for sorting by Division/Clinic/Patient Name or '2' to sort by Division/Terminal Digits or '3' to sort by Division/Clinic/Terminal Digits."
- S DIR("A")="How should the output be SORTED?",DIR("B")="1" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
- I Y'=1,Y'=2,Y'=3 S QUIT=1 Q
- S IBSRT=Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1BA 3990 printed Feb 19, 2025@00:17:35 Page 2
- IBDF1BA ;ALB/CJM - ENCOUNTER FORM (user options for printing - continuation of IBDF1B); 3/1/93
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25,34**;APR 24, 1997
- +2 ;
- TERMSTRT ;get terminal digit to restart from - OUTPUT=IBREPRNT
- +1 SET IBREPRNT=""
- SET DIR(0)="F^4:5"
- SET DIR("A")="ENTER THE LAST 4 DIGITS OF THE SSN TO BEGIN REPRINT FROM"
- SET DIR("?")="ENTER THE LAST FOUR DIGITS OF THE SSN OF THE LAST PATIENT FOR WHOM FORMS WERE PRINTED"
- +2 FOR
- DO ^DIR
- if $DATA(DIRUT)!(Y=-1)
- QUIT
- Begin DoDot:1
- +3 IF Y'?4N
- WRITE !,$CHAR(7),"MUST BE 4 NUMBERS!"
- QUIT
- +4 SET IBREPRNT=Y
- SET IBREPRNT=+($EXTRACT(IBREPRNT,3,4)_$EXTRACT(IBREPRNT,1,2))
- End DoDot:1
- if IBREPRNT'=""
- QUIT
- +5 KILL DIR
- +6 QUIT
- CLNCSTRT ;get clinic and division to restart from,OUTPUT=IBREPRNT (name of clinic) and IBSTRTDV (division to restart from)
- +1 ;
- +2 NEW NODE
- +3 SET IBREPRNT=""
- +4 SET DIR(0)="409.95,.01"
- SET DIR("A")="ENTER CLINIC TO BEGIN REPRINT FROM"
- SET DIR("?")="ENTER THE LAST CLINIC FOR WHICH ANY FORMS WERE PRINTED"
- +5 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!(+Y<0)
- QUIT
- +6 SET NODE=$GET(^SC(+Y,0))
- +7 SET IBREPRNT=$PIECE(NODE,"^")
- +8 SET IBSTRTDV=+$PIECE(NODE,"^",15)
- IF IBSTRTDV
- SET IBSTRTDV=$PIECE($GET(^DG(40.8,IBSTRTDV,0)),"^")
- +9 QUIT
- +10 ;
- SEARCH ;get the appointment data on a patient, put in IBTMP array, indexed by appointment
- +1 ;screens out any appts in clinics with nothing defined to print
- +2 NEW IBX,IBLN,CLINIC,APPT
- +3 SET (VASD("F"),VASD("T"))=IBDT
- SET VASD("W")=129
- DO SDA^VADPT
- if (VAERR!'$DATA(^UTILITY("VASD",$JOB)))
- QUIT
- +4 SET IBX=""
- FOR
- SET IBX=$ORDER(^UTILITY("VASD",$JOB,IBX))
- if IBX=""
- QUIT
- Begin DoDot:1
- +5 SET IBLN=^UTILITY("VASD",$JOB,IBX,"I")
- SET APPT=+$PIECE(IBLN,"^")
- SET CLINIC=$PIECE(IBLN,"^",2)
- +6 if 'APPT!'CLINIC
- QUIT
- +7 if '($DATA(^SD(409.95,"B",CLINIC))!$DATA(^SD(409.96,"B",+$$DIVISION^IBDF1B5(CLINIC))))
- QUIT
- +8 ;^UTILITY("VASD",$J,IBX,"E")=(EXTERNAL FORMAT) appt date time^clinic name^status^appt type
- +9 SET IBTMP(APPT)=DFN_"^"_CLINIC_"^"_IBNM_"^"_^UTILITY("VASD",$JOB,IBX,"E")
- End DoDot:1
- +10 KILL VASD,VAERR,^UTILITY("VASD",$JOB)
- +11 QUIT
- +12 ;
- DISP ;display patients/clinics appointments found and get users choice
- +1 ;sort type is by clinic,patient
- +2 NEW CLNCIEN,CLNCNAME
- +3 IF '$DATA(IBTMP)
- WRITE !!,?5,"No Active Appointments for ",IBNM," on",!,"this date in any clinic or division that has forms or reports defined to print",!
- GOTO ENDDISP
- +4 IF '$DATA(IBTMP)
- WRITE !!,?10,"No Active Appointments in a Clinic with an Encounter Form",!,?10,"for ",IBNM," on this date.",!
- GOTO ENDDISP
- +5 WRITE !!,"Appointments for ",IBNM,!
- +6 SET IBX=""
- FOR IBI=1:1
- SET IBX=$ORDER(IBTMP(IBX))
- if IBX=""
- QUIT
- SET IBLN=IBTMP(IBX)
- WRITE !,$JUSTIFY(IBI,3)," ",$EXTRACT($PIECE(IBLN,"^",5),1,20),?25," "
- FOR IBJ=4,6,7
- WRITE " ",$PIECE(IBLN,"^",IBJ)
- +7 SET DIR(0)="LO^1:"_(IBI-1)
- SET DIR("A")=" Select Appointments"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO ENDDISP
- +8 SET IBX=""
- FOR IBI=1:1
- SET IBX=$ORDER(IBTMP(IBX))
- if IBX=""
- QUIT
- IF Y[(IBI_",")
- Begin DoDot:1
- +9 SET CLNCIEN=$PIECE(IBTMP(IBX),"^",2)
- SET CLNCNAME=$PIECE(IBTMP(IBX),"^",5)
- +10 ;
- +11 ;list format - ^TMP("IBDF",$J,"P"," ",division name(but set it to " " because for selecting single appts sort by division not needed),clinic name,clinic ien,patient name,dfn,appt)=""
- +12 ;S ^TMP("IBDF",$J,"P"," ",CLNCNAME,CLNCIEN,IBNM,DFN,IBX)=""
- +13 SET ^TMP("IBDF",$JOB,"P"," ",$EXTRACT(CLNCNAME,1,25),CLNCIEN,$EXTRACT(IBNM,1,25),DFN,IBX)=""
- +14 ;also keep an index by ...,"APPT LIST",DFN,APPT)
- +15 SET ^TMP("IBDF",$JOB,"APPT LIST",DFN,IBX)=""
- End DoDot:1
- ENDDISP KILL IBTMP,IBX,IBI,IBJ,IBLN,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,^UTILITY("VASD",$JOB)
- +1 QUIT
- +2 ;
- STARTDIV() ;asks what division to restart the job from and returns division name, or "" if user declines
- +1 NEW IBDIV
- +2 KILL DIC
- SET DIC="^DG(40.8,"
- SET DIC(0)="AEQMN"
- SET DIC("A")="SELECT THE DIVISION TO START THE REPRINT FROM: "
- +3 SET IBDIV=$ORDER(^DG(40.8,0))
- if IBDIV
- SET DIC("B")=$PIECE($GET(^DG(40.8,IBDIV,0)),"^")
- +4 DO ^DIC
- KILL DIC
- +5 IF (+Y<0)!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT ""
- +6 QUIT $PIECE(Y,"^",2)
- SORTBY ;sort by clinic/patient, clinic/terminal digit, or terminal digit?
- +1 KILL DIR
- SET DIR(0)="S^1:Division/Clinic/Patient Name;2:Division/Terminal Digits;3:Division/Clinic/Terminal Digits"
- +2 SET DIR("?")="Enter '1' for sorting by Division/Clinic/Patient Name or '2' to sort by Division/Terminal Digits or '3' to sort by Division/Clinic/Terminal Digits."
- +3 SET DIR("A")="How should the output be SORTED?"
- SET DIR("B")="1"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET QUIT=1
- QUIT
- +4 IF Y'=1
- IF Y'=2
- IF Y'=3
- SET QUIT=1
- QUIT
- +5 SET IBSRT=Y
- +6 QUIT
