IBDFDE8 ;ALB/AAS - AICS Manual Data Entry, Entry for no form no appt ; 31-MAY-96
;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
;
W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
;
% N %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT
N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDAPPT,IBDSAEOK,IBDAPPT
;
I '$D(DT) D DT^DICRW
D HOME^%ZIS
W !!,"Data Entry Pre-Printed form, No appointment",!
;
STRT ; -- ask for form id
D END
S IBQUIT=0
W !
S DIR("?")="Select the patient you wish to enter data on for an encounter."
S DIR(0)="PO^2:AEQM",DIR("A")="Select Patient" D ^DIR K DIR,DA,DR,DIC
I $D(DIRUT) G END
S (IBDF("DFN"),DFN)=+Y
;
CLINIC ; -- select clinic
W !
S IBDSAEOK=0
S IBDF("CLINIC")=$$SELCL^IBDFDE6 G:IBQUIT STRTQ
I IBDF("CLINIC")=-1 G STRTQ
I IBDF("CLINIC")<1 G STRT
S CLNAME=$P($G(^SC(+IBDF("CLINIC"),0)),"^")
S CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))
;
; -- select appointment date time
W !
S IBDF("APPT")=$$ASKDT^IBDFDE0("Appointment Date/Time: ","","AEQRXT","",DT+.24,"D LSTAP^IBDFDE8") G:IBQUIT STRTQ
I IBDF("APPT")<1 G CLINIC
;
W ! D LISTONE W !
;
;
I IBDAPPT S IBDSAEOK=$$ASKYN^IBDFDE0("Okay to use "_$$FMTE^XLFDT(IBDF("APPT"))_" for Data Entry","No")
I 'IBDAPPT S IBDSAEOK=$$ASKYN^IBDFDE0("Okay to Create Stand Alone Encounter","No")
W !
G:'IBDSAEOK CLINIC G:IBQUIT STRTQ
;
; -- if no form create entry
S FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)
I FORMLST="" D ANYWAY^IBDFDE6
;
G:IBQUIT STRTQ
;
I FORMLST,IBDSAEOK F IBDX=1:1 S IBDF("FORM")=$P(FORMLST,"^",IBDX) Q:IBDF("FORM")="" I IBDF("FORM")'="" D EN^IBDFDE K IBDSEL,IBDPI Q:IBQUIT
;
STRTQ K IBDSAEOK
G STRT:'IBQUIT
;
END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
Q
;
LSTAP ; -- list appointments for date range
N IBDI,BEGIN,HELP,CNT,DOW,NODAYS
S HELP=1,CNT=0
W !
S DOW=$$DOW^XLFDT(DT,1)
S NODAYS=$S(DOW=1:5,DOW=2:5,DOW=3:5,DOW>3:3,DOW=0:4)
S BEGIN=$$FMADD^XLFDT(DT,-NODAYS)
F IBDI=1:1:NODAYS S IBDF("APPT")=$$FMADD^XLFDT(BEGIN,IBDI) D LISTONE
W:CNT !
Q
;
LISTONE ; -- List appointments for one date
N NEXT,NODE
S NEXT=$E(IBDF("APPT"),1,7),IBDAPPT=0
S:'$G(HELP) CNT=0
F S NEXT=$O(^DPT(DFN,"S",NEXT)) Q:'NEXT!(NEXT>(IBDF("APPT")+.24)) D
.S CNT=CNT+1
.S NODE=$G(^DPT(DFN,"S",NEXT,0))
.I NEXT=IBDF("APPT"),+NODE=IBDF("CLINIC") S IBDAPPT=1
.I CNT=1 W !,"Patient has the following appointments: "
.W !?3,$$FMTE^XLFDT(NEXT),?25,$E($P($G(^SC(+NODE,0)),"^"),1,23)
.D FRMSTAT
I CNT=0,'$G(HELP) W !,"No appointments for Patient found on ",$$FMTE^XLFDT($E(IBDF("APPT"),1,7))
Q
;
FRMSTAT ; -- count forms and form status for appointments
N FORM,CNT,STATUS,IBJ,X,Y,C
S FORM=$$FINDID^IBDF18C(DFN,NEXT,"",1),STATUS="NO FORM PRINTED"
S CNT=0 F IBJ=1:1 S X=$P(FORM,"^",IBJ) Q:X="" S CNT=CNT+1
I +FORM S Y=$P($G(^IBD(357.96,+FORM,0)),"^",11),C=$P(^DD(357.96,.11,0),"^",2) D Y^DIQ S STATUS=Y
W ?50,$E($G(STATUS),1,25),?76,"("_CNT_")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE8 3419 printed Dec 13, 2024@02:52:26 Page 2
IBDFDE8 ;ALB/AAS - AICS Manual Data Entry, Entry for no form no appt ; 31-MAY-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
+2 ;
+3 ;Code set Versioning
WRITE !,?4,"** This option is OUT OF ORDER **"
QUIT
+4 ;
% NEW %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT
+1 NEW IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDAPPT,IBDSAEOK,IBDAPPT
+2 ;
+3 IF '$DATA(DT)
DO DT^DICRW
+4 DO HOME^%ZIS
+5 WRITE !!,"Data Entry Pre-Printed form, No appointment",!
+6 ;
STRT ; -- ask for form id
+1 DO END
+2 SET IBQUIT=0
+3 WRITE !
+4 SET DIR("?")="Select the patient you wish to enter data on for an encounter."
+5 SET DIR(0)="PO^2:AEQM"
SET DIR("A")="Select Patient"
DO ^DIR
KILL DIR,DA,DR,DIC
+6 IF $DATA(DIRUT)
GOTO END
+7 SET (IBDF("DFN"),DFN)=+Y
+8 ;
CLINIC ; -- select clinic
+1 WRITE !
+2 SET IBDSAEOK=0
+3 SET IBDF("CLINIC")=$$SELCL^IBDFDE6
if IBQUIT
GOTO STRTQ
+4 IF IBDF("CLINIC")=-1
GOTO STRTQ
+5 IF IBDF("CLINIC")<1
GOTO STRT
+6 SET CLNAME=$PIECE($GET(^SC(+IBDF("CLINIC"),0)),"^")
+7 SET CLSETUP=$GET(^SD(409.95,+$ORDER(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))
+8 ;
+9 ; -- select appointment date time
+10 WRITE !
+11 SET IBDF("APPT")=$$ASKDT^IBDFDE0("Appointment Date/Time: ","","AEQRXT","",DT+.24,"D LSTAP^IBDFDE8")
if IBQUIT
GOTO STRTQ
+12 IF IBDF("APPT")<1
GOTO CLINIC
+13 ;
+14 WRITE !
DO LISTONE
WRITE !
+15 ;
+16 ;
+17 IF IBDAPPT
SET IBDSAEOK=$$ASKYN^IBDFDE0("Okay to use "_$$FMTE^XLFDT(IBDF("APPT"))_" for Data Entry","No")
+18 IF 'IBDAPPT
SET IBDSAEOK=$$ASKYN^IBDFDE0("Okay to Create Stand Alone Encounter","No")
+19 WRITE !
+20 if 'IBDSAEOK
GOTO CLINIC
if IBQUIT
GOTO STRTQ
+21 ;
+22 ; -- if no form create entry
+23 SET FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)
+24 IF FORMLST=""
DO ANYWAY^IBDFDE6
+25 ;
+26 if IBQUIT
GOTO STRTQ
+27 ;
+28 IF FORMLST
IF IBDSAEOK
FOR IBDX=1:1
SET IBDF("FORM")=$PIECE(FORMLST,"^",IBDX)
if IBDF("FORM")=""
QUIT
IF IBDF("FORM")'=""
DO EN^IBDFDE
KILL IBDSEL,IBDPI
if IBQUIT
QUIT
+29 ;
STRTQ KILL IBDSAEOK
+1 if 'IBQUIT
GOTO STRT
+2 ;
END KILL I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
+1 KILL ^TMP("IBD-ASK",$JOB),^TMP("IBD-LCODE",$JOB),^TMP("IBD-LST",$JOB),^TMP("IBD-LTEXT",$JOB),^TMP("IBD-OBJ",$JOB)
+2 QUIT
+3 ;
LSTAP ; -- list appointments for date range
+1 NEW IBDI,BEGIN,HELP,CNT,DOW,NODAYS
+2 SET HELP=1
SET CNT=0
+3 WRITE !
+4 SET DOW=$$DOW^XLFDT(DT,1)
+5 SET NODAYS=$SELECT(DOW=1:5,DOW=2:5,DOW=3:5,DOW>3:3,DOW=0:4)
+6 SET BEGIN=$$FMADD^XLFDT(DT,-NODAYS)
+7 FOR IBDI=1:1:NODAYS
SET IBDF("APPT")=$$FMADD^XLFDT(BEGIN,IBDI)
DO LISTONE
+8 if CNT
WRITE !
+9 QUIT
+10 ;
LISTONE ; -- List appointments for one date
+1 NEW NEXT,NODE
+2 SET NEXT=$EXTRACT(IBDF("APPT"),1,7)
SET IBDAPPT=0
+3 if '$GET(HELP)
SET CNT=0
+4 FOR
SET NEXT=$ORDER(^DPT(DFN,"S",NEXT))
if 'NEXT!(NEXT>(IBDF("APPT")+.24))
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
+6 SET NODE=$GET(^DPT(DFN,"S",NEXT,0))
+7 IF NEXT=IBDF("APPT")
IF +NODE=IBDF("CLINIC")
SET IBDAPPT=1
+8 IF CNT=1
WRITE !,"Patient has the following appointments: "
+9 WRITE !?3,$$FMTE^XLFDT(NEXT),?25,$EXTRACT($PIECE($GET(^SC(+NODE,0)),"^"),1,23)
+10 DO FRMSTAT
End DoDot:1
+11 IF CNT=0
IF '$GET(HELP)
WRITE !,"No appointments for Patient found on ",$$FMTE^XLFDT($EXTRACT(IBDF("APPT"),1,7))
+12 QUIT
+13 ;
FRMSTAT ; -- count forms and form status for appointments
+1 NEW FORM,CNT,STATUS,IBJ,X,Y,C
+2 SET FORM=$$FINDID^IBDF18C(DFN,NEXT,"",1)
SET STATUS="NO FORM PRINTED"
+3 SET CNT=0
FOR IBJ=1:1
SET X=$PIECE(FORM,"^",IBJ)
if X=""
QUIT
SET CNT=CNT+1
+4 IF +FORM
SET Y=$PIECE($GET(^IBD(357.96,+FORM,0)),"^",11)
SET C=$PIECE(^DD(357.96,.11,0),"^",2)
DO Y^DIQ
SET STATUS=Y
+5 WRITE ?50,$EXTRACT($GET(STATUS),1,25),?76,"("_CNT_")"
+6 QUIT
