Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFDE7

IBDFDE7.m

Go to the documentation of this file. 
  1. IBDFDE7 ;ALB/AAS - AICS Manual Data Entry, Entry point for Group Clinics ; 29-APR-96
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**36**;APR 24, 1997
  1.  ;
  1. % N %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBDA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT
  1.  N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDX,ANS,CLNAME,CLSETUP,IBDSC,FORM,FORMLST,IBDFDT
  1.  ;
  1.  I '$D(DT) D DT^DICRW
  1.  D HOME^%ZIS
  1.  W !!,"Data Entry of Encounter Forms for Group Clinics",!
  1.  ;
  1. STRT ; -- ask for Clinic, appt. date/time
  1.  ;    list patients, allow to deselect
  1.  ;    find all forms for appt., then go through 1 at a time
  1.  ;    then send data for each patient
  1.  ;
  1.  D END W !
  1.  S IBQUIT=0
  1.  S (IBDSC,IBDF("CLINIC"))=$$SELCL^IBDFDE6 G:IBQUIT STRTQ
  1.  I IBDSC<1 S IBQUIT=1 G STRTQ
  1.  S CLNAME=$P($G(^SC(+IBDSC,0)),"^")
  1.  S CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDSC,0)),0))
  1.  ;
  1. OVER ;
  1.  W !
  1.  S IBQUIT=0
  1.  S IBDFDT=$$SELAPT(.IBDF) G:IBQUIT STRTQ
  1.  I IBDFDT<0 G STRT
  1.  S IBDF("APPT")=IBDFDT
  1.  ;
  1.  D BLD
  1.  I '$D(^TMP("IBD-PL",$J,IBDF("CLINIC"))) W !!,"No valid appointments at that Date/Time!",!! G STRTQ
  1.  ;
  1.  D HDR^IBDFDE6,LIST^IBDFDE6
  1.  W !!
  1.  D EXCLUD
  1.  I IBQUIT=2 S IBQUIT=0 G STRTQ
  1.  G:IBQUIT STRTQ
  1.  ;
  1.  ; -- get first patient, check form(s)
  1.  ;   do data entry on form and if okay pass data for all patients
  1.  S IBDSTRT=+$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),0))
  1.  S NODE=$G(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBDSTRT))
  1.  S (DFN,IBDFN)=+NODE
  1.  S FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)
  1.  I FORMLST="" W !,"No forms Printed for first Patient" D ANYWAY^IBDFDE6
  1.  I FORMLST="" G OVERQ
  1.  S IBDF("SAVE")=1 ;save ibdsel(array)
  1.  F IBDX=1:1 S IBDF("FORM")=$P(FORMLST,"^",IBDX) Q:IBDF("FORM")=""  I IBDF("FORM")'="" D EN^IBDFDE D
  1.  .I $G(IBDF("NOTHING"))!(IBQUIT) W !! Q
  1.  .D ALLPTS K IBDSEL,IBDPI Q:IBQUIT
  1.  K IBDF("SAVE")
  1.  ;
  1. OVERQ G OVER
  1.  ;
  1. STRTQ D PAUSE^IBDFDE G:IBQUIT END
  1.  G STRT
  1.  ;
  1. ALLPTS ; -- loop through all patients, merge ibdf=^tmp("ibd-save),
  1.  ;    reset dfn, pass data to ibdfrpc4
  1.  N PARAM,FORMID,IBX,NODE
  1.  S FORMID=$P(^IBD(357.96,+IBDF("FORM"),0),"^",4)
  1.  S PARAM=$P($G(^IBD(357.09,1,0)),"^",7)
  1.  I $G(^TMP("IBD-SAVED",$J,"DYNAMIC")) W !!,"Form contains patient specific information, Not available for this option!",!! G ALLPTQ
  1.  S IBDA=IBDSTRT
  1.  F  S IBDA=$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBDA)) Q:IBDA=""!(IBQUIT)  D
  1.  .S IBX=IBDA
  1.  .S NODE=$G(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBX))
  1.  .M IBDF=^TMP("IBD-SAVED",$J)
  1.  .S (DFN,IBDF("DFN"))=+NODE
  1.  .S IBDF("SDOE")=$P(NODE,"^",22)
  1.  .S IBDF("FORM")=+$$FID^IBDF18C(DFN,IBDF("APPT"),1,FORMID,IBDF("CLINIC"))
  1.  .W !!,"Check out interview for: ",$P($G(^DPT(DFN,0)),"^")
  1.  .K IBDCO,IBDF("AO"),IBDF("SC"),IBDF("IR"),IBDF("EC"),IBDF("MST")
  1.  .D CHKOUT^IBDFDE0(IBDF("SDOE"))
  1.  .M IBDF=IBDCO
  1.  .D SEND^IBDFRPC4(.RESULT,.IBDF)
  1.  .I PARAM=3 D DISP^IBDFDE1
  1.  .I PARAM,$D(PXCA("ERROR"))!($D(PXCA("WARNING"))) D ERR^IBDFDE1
  1.  .I $P($G(^IBD(357.09,1,0)),"^",6) D MAKAPPT^IBDFDE1
  1.  ;
  1.  K ^TMP("IBD-SAVED",$J)
  1. ALLPTQ Q
  1.  ;
  1. SELAPT(IBDF) ; -- select appointment date/time for a clinic
  1.  N DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT
  1.  S ANS=-1
  1.  S DIR(0)="DO^:NOW:AEXRT^D SCRN^IBDFDE7",DIR("A")="Appointment Date/Time"
  1.  S DIR("?")="Enter the date/time for the clinic that you wish to enter encounter forms for.  Appointments must be present to enter the date time."
  1.  S DIR("??")="^D APDT^IBDFDE7"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) G SELAPQ
  1.  S ANS=+Y
  1. SELAPQ Q ANS
  1.  ;
  1. SCRN ; -- input transform logic for selecting an appointment date/time
  1.  I $G(IBDF("CLINIC"))="" K X
  1.  I '$D(^SC(IBDF("CLINIC"),"S",Y,1)) W $C(7),"??  No appointments that time." K X
  1.  Q
  1.  ;
  1. EXCLUD ; -- select patient(s) to process
  1.  S RESULT=""
  1.  S DIR("?")="Enter the number of the patient to exclude."
  1.  S DIR("??")="^D LIST^IBDFDE6"
  1.  S DIR(0)="FO^1:30",DIR("A")="Exclude Patient"
  1.  I RESULT'="" S DIR("A")="Exclude Another Patient"
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!($D(DUOUT)) S IBQUIT=1 G EXCLUDQ
  1.  S ANS=Y
  1.  I ANS="" G EXCLUDQ
  1.  I ANS'=+ANS W !,"You must select a number from the list."
  1.  I ANS=+ANS,$D(^TMP("IBD-PL",$J,IBDF("CLINIC"),ANS)) D
  1.  .S RESULT=^TMP("IBD-PL",$J,IBDF("CLINIC"),ANS)
  1.  .K ^TMP("IBD-PL",$J,IBDF("CLINIC"),ANS),^TMP("IBD-PLN",$J,IBDF("CLINIC"),$P($G(^DPT(+RESULT,0)),"^"))
  1.  .W "  ",$P($G(^DPT(+RESULT,0)),"^"),"   ","Excluded!"
  1.  ;
  1.  I '$D(^TMP("IBD-PL",$J,IBDF("CLINIC"))) W !!,"No patients left" S IBQUIT=2 G EXCLUDQ
  1.  ;
  1.  G EXCLUD
  1. EXCLUDQ Q
  1.  ;
  1. BLD ; -- Find all appointments for a date
  1.  K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J)
  1.  N SC,IBD,IBD1
  1.  S IBD=IBDFDT,SC=IBDF("CLINIC"),CNT=0
  1.  S IBD1=0 F  S IBD1=$O(^SC(SC,"S",IBD,1,IBD1)) Q:'IBD1  D
  1.  .S NODE=$G(^SC(SC,"S",IBD,1,IBD1,0))
  1.  .S SNODE=$G(^DPT(+NODE,"S",IBD,0))
  1.  .S X=$P(SNODE,"^",2)
  1.  .I X'="","CNAPCA"[X Q  ;inpatient appointments are okay
  1.  .S (DFN,IBDF("DFN"))=+NODE
  1.  .S CNT=CNT+1
  1.  .S ^TMP("IBD-PL",$J,SC,CNT)=DFN_"^"_IBD_"^"_SNODE
  1.  .S ^TMP("IBD-PLN",$J,SC,$P(^DPT(DFN,0),"^"))=DFN_"^"_IBD_"^"_SNODE
  1.  Q
  1.  ;
  1. LIST ; -- print list of patients
  1.  N IBD,IBJ,FORM,STATUS
  1.  S IBD=0 F  S IBD=$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)) Q:'IBD  D
  1.  .S DFN=+$G(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)),APPT=$P($G(^(IBD)),"^",2),SNODE=$P($G(^(IBD)),"^",3,99)
  1.  .S FORM=+$$FINDID^IBDF18C(DFN,APPT,"",1),STATUS="NO FORM PRINTED"
  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
  1.  .W !?2,IBD,?5,$E($P(^DPT(DFN,0),"^"),1,20),?29,$P($G(^DPT(DFN,.36)),"^",3),?43,$$FMTE^XLFDT(+APPT),?64,$E($G(STATUS),1,16)
  1.  Q
  1.  ;
  1. APDT ; -- list last 30 days appointment dates in clinic
  1.  S (X,Y)=$$FMADD^XLFDT(DT,-60),CNT=0
  1.  F  S X=$O(^SC(IBDF("CLINIC"),"S",X)) Q:'X!(X>DT)  D
  1.  .S Y=X,CNT=CNT+1
  1.  .I CNT=1 W !!,"The following are valid Appointment date/times in the past 60 days:"
  1.  .W:(CNT#3=1) !,?3,$$FMTE^XLFDT(Y)
  1.  .W:(CNT#3=2) ?30,$$FMTE^XLFDT(Y)
  1.  .W:(CNT#3=0) ?60,$$FMTE^XLFDT(Y)
  1.  Q
  1.  ;
  1. HDR ; -- print Clinic header
  1.  W @IOF
  1.  W !,"      Clinic: ",$E(CLNAME,1,25) W ?40,"       Date: ",$$FMTE^XLFDT(IBDFDT)
  1.  S FORM=$P(CLSETUP,"^",2),IBDFMNME=$P($G(^IBE(357,+FORM,0)),"^")
  1.  W !,"  Basic Form: ",$E(IBDFMNME,1,25) ;W ?40,"Form Status: ",$E(IBDFMSTE,1,25)
  1.  W !,$TR($J(" ",IOM)," ","=")
  1.  Q
  1.  ;
  1. END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDA,SDFN
  1.  K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J),^TMP("IBD-SAVED",$J),^TMP("IBD-MORE",$J),^TMP("IBD-PLCHK",$J),^TMP("IBD-PL4",$J),^TMP("IBD-PLB",$J)
  1.  K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
  1.  Q