source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE8.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1IBDFDE8 ;ALB/AAS - AICS Manual Data Entry, Entry for no form no appt ; 31-MAY-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
3 ;
4 W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
5 ;
6% 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
7 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
8 ;
9 I '$D(DT) D DT^DICRW
10 D HOME^%ZIS
11 W !!,"Data Entry Pre-Printed form, No appointment",!
12 ;
13STRT ; -- ask for form id
14 D END
15 S IBQUIT=0
16 W !
17 S DIR("?")="Select the patient you wish to enter data on for an encounter."
18 S DIR(0)="PO^2:AEQM",DIR("A")="Select Patient" D ^DIR K DIR,DA,DR,DIC
19 I $D(DIRUT) G END
20 S (IBDF("DFN"),DFN)=+Y
21 ;
22CLINIC ; -- select clinic
23 W !
24 S IBDSAEOK=0
25 S IBDF("CLINIC")=$$SELCL^IBDFDE6 G:IBQUIT STRTQ
26 I IBDF("CLINIC")=-1 G STRTQ
27 I IBDF("CLINIC")<1 G STRT
28 S CLNAME=$P($G(^SC(+IBDF("CLINIC"),0)),"^")
29 S CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))
30 ;
31 ; -- select appointment date time
32 W !
33 S IBDF("APPT")=$$ASKDT^IBDFDE0("Appointment Date/Time: ","","AEQRXT","",DT+.24,"D LSTAP^IBDFDE8") G:IBQUIT STRTQ
34 I IBDF("APPT")<1 G CLINIC
35 ;
36 W ! D LISTONE W !
37 ;
38 ;
39 I IBDAPPT S IBDSAEOK=$$ASKYN^IBDFDE0("Okay to use "_$$FMTE^XLFDT(IBDF("APPT"))_" for Data Entry","No")
40 I 'IBDAPPT S IBDSAEOK=$$ASKYN^IBDFDE0("Okay to Create Stand Alone Encounter","No")
41 W !
42 G:'IBDSAEOK CLINIC G:IBQUIT STRTQ
43 ;
44 ; -- if no form create entry
45 S FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)
46 I FORMLST="" D ANYWAY^IBDFDE6
47 ;
48 G:IBQUIT STRTQ
49 ;
50 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
51 ;
52STRTQ K IBDSAEOK
53 G STRT:'IBQUIT
54 ;
55END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
56 K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
57 Q
58 ;
59LSTAP ; -- list appointments for date range
60 N IBDI,BEGIN,HELP,CNT,DOW,NODAYS
61 S HELP=1,CNT=0
62 W !
63 S DOW=$$DOW^XLFDT(DT,1)
64 S NODAYS=$S(DOW=1:5,DOW=2:5,DOW=3:5,DOW>3:3,DOW=0:4)
65 S BEGIN=$$FMADD^XLFDT(DT,-NODAYS)
66 F IBDI=1:1:NODAYS S IBDF("APPT")=$$FMADD^XLFDT(BEGIN,IBDI) D LISTONE
67 W:CNT !
68 Q
69 ;
70LISTONE ; -- List appointments for one date
71 N NEXT,NODE
72 S NEXT=$E(IBDF("APPT"),1,7),IBDAPPT=0
73 S:'$G(HELP) CNT=0
74 F S NEXT=$O(^DPT(DFN,"S",NEXT)) Q:'NEXT!(NEXT>(IBDF("APPT")+.24)) D
75 .S CNT=CNT+1
76 .S NODE=$G(^DPT(DFN,"S",NEXT,0))
77 .I NEXT=IBDF("APPT"),+NODE=IBDF("CLINIC") S IBDAPPT=1
78 .I CNT=1 W !,"Patient has the following appointments: "
79 .W !?3,$$FMTE^XLFDT(NEXT),?25,$E($P($G(^SC(+NODE,0)),"^"),1,23)
80 .D FRMSTAT
81 I CNT=0,'$G(HELP) W !,"No appointments for Patient found on ",$$FMTE^XLFDT($E(IBDF("APPT"),1,7))
82 Q
83 ;
84FRMSTAT ; -- count forms and form status for appointments
85 N FORM,CNT,STATUS,IBJ,X,Y,C
86 S FORM=$$FINDID^IBDF18C(DFN,NEXT,"",1),STATUS="NO FORM PRINTED"
87 S CNT=0 F IBJ=1:1 S X=$P(FORM,"^",IBJ) Q:X="" S CNT=CNT+1
88 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
89 W ?50,$E($G(STATUS),1,25),?76,"("_CNT_")"
90 Q
Note: See TracBrowser for help on using the repository browser.