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

IBDFDE1.m

Go to the documentation of this file.
  1. IBDFDE1 ;ALB/AAS - AICS Data Entry, Final check; 2/24/96 [ 11/12/96 2:12 PM ]
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,36,63**;APR 24, 1997;Build 80
  1. ;
  1. ;
  1. ; -- calls IBDFRPC4 to pass data to pce
  1. ;
  1. % G ^IBDFDE
  1. ;
  1. FINAL ; -- display everything selected and check okay
  1. ; -- input IBDSEL :
  1. ; $p1 := package interface ien (for input)
  1. ; $p2 := code to send (may be internal or external)
  1. ; $p3 := text to send
  1. ; $p4 := hdr to send (optional)
  1. ; $p5 := clinic lexicon pointer (optional)
  1. ; $p6 := qualifier (i.e. primary or secondary)
  1. ; $P7 :=
  1. ; $p8 :=
  1. ; $p9 :=
  1. ; $p10 := external value of code (optional)
  1. ;
  1. N I,X,DIR,DIRUT,DUOUT,DTOUT,PARAM,IBDCNT,MODSAVE,XX
  1. K IBDREDIT
  1. I $G(IBDSEL(0))<1,$G(IBDCO("CO"))="",$G(IBDCO("SC"))="",$G(IBDCO("AO"))="",$G(IBDCO("IR"))="",$G(IBDCO("EC"))="",$G(IBDCO("MST"))="" W !!,"Nothing Selected!!" S IBDF("NOTHING")=1 Q
  1. ;
  1. S (IBDCNT,IBQUIT)=0
  1. W !!,"You have entered the following:"
  1. D WRITE^IBDFDE0(IBDF("SDOE"),.IBDCNT)
  1. S I=0 F S I=$O(IBDSEL(I)) Q:I="" D
  1. . S IBDCNT=IBDCNT+1
  1. . K MODSAVE
  1. . D LINE(IBDCNT,IBDSEL(I)) D
  1. .. I $D(IBDSEL(I,"MODIFIER")) D MODLIST(I)
  1. S DIR(0)="Y",DIR("B")="No",DIR("A")="Is this Okay" D ^DIR
  1. I $D(DIRUT) S IBQUIT=1 W !!,"No action Taken",! G FINALQ
  1. I Y<1 D DEL S:'IBQUIT IBDREDIT=1 G FINALQ
  1. I Y'=1 G FINALQ
  1. M IBDF=IBDSEL
  1. ;I $G(^DPT(DFN,"S",IBDF("APPT"),0))="" D FNDAPPT I 'IBDOK W !!,"No action Taken",! Q
  1. I $G(IBDF("SAVE")) M ^TMP("IBD-SAVED",$J)=IBDF ;don't save checkout data
  1. M IBDF=IBDCO
  1. W !!,"Sending Data to PCE..."
  1. D SEND^IBDFRPC4(.RESULT,.IBDF)
  1. W $S($G(RESULT(0)):" Successful",1:" Unsuccessful"),!!
  1. I $D(IBDSTRT) S IBDFIN=$H S IBDTIME=$$HDIFF^XLFDT(IBDFIN,IBDSTRT,2)
  1. S PARAM=$P($G(^IBD(357.09,1,0)),"^",7)
  1. I PARAM=3 D DISP
  1. I PARAM,$D(PXCA("ERROR"))!($D(PXCA("WARNING"))) D ERR
  1. I $G(IBDTIME) D
  1. .W !!,"Elapsed time for data entry: ",IBDTIME," seconds.",!!
  1. .S IBDF("SECONDS")=IBDTIME,IBDF("USER")=DUZ
  1. .D ETIME^IBDFBK1(.RESULT,.IBDF)
  1. I '$G(IBDREDIT),$P($G(^IBD(357.09,1,0)),"^",6) D MAKAPPT
  1. FINALQ K SDFN,ZTSK,SECONDS,LEX,ORVP,SEL1,PXCAVSIT,PXCA,PXCASTAT
  1. Q
  1. ;
  1. DEL ; -- delete selected entry
  1. N I,J,DIR,DIRUT,DUOUT,DTOUT,CNT,CNTD,IBD,IBD1,IBDEL
  1. S CNT=0
  1. W !
  1. S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to delete an item"
  1. S DIR("?")="Enter 'Yes' if you want to delete an item or 'No' to just add more items."
  1. D ^DIR K DIR
  1. I $D(DIRUT) S IBQUIT=1 Q
  1. Q:Y<1
  1. S IBD=0 F S IBD=$O(IBDSEL(IBD)) Q:IBD="" S CNT=CNT+1,IBDEL(CNT)=IBD D LINE(CNT,IBDSEL(IBD)) D
  1. . I $D(IBDSEL(IBD,"MODIFIER")) D MODLIST(IBD)
  1. Q:CNT<1
  1. S DIR(0)="L^1:"_CNT D ^DIR K DIR
  1. I $D(DIRUT) W !,"Nothing Deleted" Q
  1. F IBD1=1:1 S IBDEL=$P(Y,",",IBD1) Q:IBDEL="" D
  1. .W !,"Deleting "_IBDEL
  1. .S QLFR=$P(IBDSEL(IBDEL(IBDEL)),"^",6)
  1. .I QLFR'="" K IBDPI(+IBDSEL(IBDEL(IBDEL)),QLFR)
  1. .K IBDPI(+IBDSEL(IBDEL(IBDEL)),IBDEL(IBDEL))
  1. .K IBDSEL(IBDEL(IBDEL))
  1. .K IBDEL(IBDEL)
  1. .S CNTD=$G(CNTD)+1
  1. I $G(CNTD)=CNT S IBDSEL(0)=0
  1. W !
  1. DELQ Q
  1. ;
  1. LINE(CNT,IBD) ; -- write one line of text
  1. W !,?3,CNT,?7,$S($P(IBD,"^",8)'="":$P(IBD,"^",8),1:$E($P($P($G(^IBE(357.6,+IBD,0)),"^"),"INPUT ",2),1,22)),?31,$E($P(IBD,"^",3),1,30)
  1. W ?62,$S($P(IBD,"^",10)'="":$P(IBD,"^",10),$P($G(^IBE(357.6,+IBD,0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX($P(IBD,"^",2)),1:$P(IBD,"^",2))
  1. W ?70,$E($S($P(IBD,"^",9)'="":$P(IBD,"^",9),1:$P(IBD,"^",6)),1,10)
  1. S SLCTN=$P(IBD,"^",12) I SLCTN'="" D
  1. . ;list modifiers
  1. . N CODE
  1. . Q:'$D(^IBE(357.3,SLCTN,3))
  1. . S CODE=$P($G(^IBE(357.3,SLCTN,0)),"^") Q:CODE=""
  1. . W !?11,"Associated Modifier(s): "
  1. . S MOD=0 F S MOD=$O(^IBE(357.3,SLCTN,3,MOD)) Q:'MOD D
  1. .. S MODSAVE=$P($G(^IBE(357.3,SLCTN,3,MOD,0)),"^")
  1. .. S MODSAVE(MODSAVE)=""
  1. .. S XX=$P($$MODP^ICPTMOD(CODE,MODSAVE,"E"),"^",2)
  1. .. W !,?15,MODSAVE,?20,XX
  1. Q
  1. ;
  1. MODLIST(I) ; -- list modifiers if in array
  1. ;
  1. W !?11,"Selected during Data Entry Modifier(s): "
  1. N CODE
  1. S CODE=$P($G(IBDSEL(I)),"^",2)
  1. S MOD=0 F S MOD=$O(IBDSEL(I,"MODIFIER",MOD)) Q:'MOD D
  1. .; --quitting if duplicate entry
  1. . Q:$D(MODSAVE(IBDSEL(I,"MODIFIER",MOD)))
  1. . S MODSAVE=IBDSEL(I,"MODIFIER",MOD)
  1. . S XX=$P($$MODP^ICPTMOD(CODE,MODSAVE,"E"),"^",2)
  1. . W !,?15,MODSAVE,?20,XX
  1. Q
  1. LEX(VAL) ; -- get output of lexicon entry
  1. N IBDIMP,IBDIBX
  1. S IBDIMP=$$IMPDATE^IBDUTICD(30)
  1. S IBDIBX=799.9
  1. I DT'<IBDIMP S IBDIBX="R69."
  1. I $D(^LEX)>1 S X="LEXU" X ^%ZOSF("TEST") I $T S VAL=$$ICDONE^LEXU(VAL) S:$L(VAL)<1 VAL=IBDIBX Q VAL ;clinical lexicon next version to be in ^LEX
  1. S X="GMPTU" X ^%ZOSF("TEST") I $T S VAL=$$ICDONE^GMPTU(VAL) S:$L(VAL)<1 VAL=IBDIBX Q VAL
  1. Q IBDIBX
  1. ;
  1. MAKAPPT ; -- ask make appointment stuff
  1. N %I,%T,I,J,X,Y,DIC,DA,DIR,DIRUT,DUOUT,IBDFN,RTCLEX,SDALLE,SDATD,SDAV,SDCLN,SDDECOD,SDEC,SDEMP,SDFN,SDHX,SDLOCK,SDMADE,SDNOT,SDOEL,SDPL,SDRE,SDRT,SDSOH,SDT,SDTTM,SDY,VSITON,VSIT,XQXFLG
  1. ;
  1. I $G(IBDF("NOAPPT")) G MAKAPQ
  1. S DIR("?")="Enter 'Yes' to make another appointment for this patient or 'No' if no appointment is to be made."
  1. S DIR(0)="Y",DIR("A")="Do you wish to make a follow-up appointment for "_$P(^DPT(IBDF("DFN"),0),"^")
  1. D ^DIR K DIR
  1. I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G MAKAPQ
  1. I Y<1 G MAKAPQ
  1. ;
  1. S (SDFN,IBDFN,DFN)=$G(IBDF("DFN")) ;use same patient, don't ask patient, ask clinic
  1. ;S SDCLN=IBDF("CLINIC") ;use same clinic, don't ask clinic
  1. D ^SDM
  1. S DFN=IBDFN K SDFN
  1. MAKAPQ Q
  1. ;
  1. ERR ; -- if processing of errors is on do display
  1. ; ask if want to re-edit
  1. N I,J,ERR,LCNT,DIR,DIRUT,DUOUT
  1. S LCNT=0
  1. D EW^IBDFBK2(.ERR,.PXCA,.LCNT)
  1. ;
  1. W !!!,"The following Error(s) occurred while validating data in PCE for: ",$P($G(^DPT(IBDF("DFN"),0)),"^")
  1. S I=0 F S I=$O(ERR(I)) Q:'I W !?4,$E(ERR(I),1,75) I $L(ERR(I))>75 W !?10,$E(ERR(I),76,140)
  1. W !
  1. Q:$G(IBDF("SAVE"))
  1. S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to Re-Edit"
  1. D ^DIR K DIR
  1. I Y=1 D
  1. .S IBDREDIT=1
  1. .K IBDF("CO"),IBDF("IR"),IBDF("SC"),IBDF("EC"),IBDF("AO"),IBDF("MST")
  1. .S I=0 F S I=$O(IBDF(I)) Q:'I K IBDF(I)
  1. I $D(DIRUT) S IBQUIT=1
  1. Q
  1. ;
  1. DISP ; -- display data based on pxca array
  1. N I,LST,LCNT
  1. S LCNT=0
  1. D LSTDATA^IBDFBK3(.LST,.PXCA,.LCNT)
  1. W !!!,"The following data was sent to PCE for: ",$P($G(^DPT(IBDF("DFN"),0)),"^")
  1. W !,?4,"Clinic: ",$P($G(^SC(+$P($G(PXCA("ENCOUNTER")),"^",3),0)),"^")," at ",$$FMTE^XLFDT(+$G(PXCA("ENCOUNTER")))
  1. S I=0 F S I=$O(LST(I)) Q:'I W !?4,$E(LST(I),1,75) I $L(LST(I))>75 W !?10,$E(LST(I),76,140)
  1. W !
  1. Q
  1. ;
  1. FNDAPPT ; -- if form is not associated with an appointment see any in clinic
  1. I $G(IBDSAEOK) S IBDOK=1 G FNDQ
  1. N IBDI,IBDJ,X,NODE,CNT,IOINHI,IOINORM,NEWAPPT,CLNAM,FORMLST,DIR,DIRUT,DUOUT,DTOUT
  1. S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. S IBDI=$E(IBDF("APPT"),1,7),IBDJ=IBDI+.24,CNT=0
  1. F S IBDI=$O(^DPT(DFN,"S",IBDI)) Q:'IBDI!(IBDI>IBDJ) D G:CNT<1 FNDQ
  1. .S NODE=$G(^DPT(DFN,"S",IBDI,0))
  1. .Q:+NODE'=IBDF("CLINIC")
  1. .S CNT=CNT+1,CLNAM=$E($P(^SC(IBDF("CLINIC"),0),"^"),1,20),NEWAPPT(CNT)=IBDI
  1. .I CNT=1 W $C(7),!!,IOINHI,"Warning:"," You are about to create a stand alone visit for: ",IOINORM,!,$E($P(^DPT(DFN,0),"^"),1,25),?27,CLNAM,?49,$$FMTE^XLFDT(IBDF("APPT"))
  1. .S FORMLST=$$FINDID^IBDF18C(DFN,IBDI,"",1)
  1. .W !,IOINHI,"Patient has appointment in ",CLNAM,?49,$$FMTE^XLFDT(IBDI)," ID: ",$TR($E(FORMLST,1,($L(FORMLST)-1)),"^",","),IOINORM
  1. ;
  1. W ! S IBDOK=$$ASKYN^IBDFDE0("Okay to Create Stand Alone Encounter",0) W !
  1. I $G(IBDOK)<0 S IBDOK=0
  1. G:IBDOK FNDQ
  1. ;
  1. ; -- ask if want to use appt. date time
  1. I CNT=1 D
  1. .S IBDOK=$$ASKYN^IBDFDE0("Okay to use "_$$FMTE^XLFDT(NEWAPPT(1))_" appointment date/time",1) W !
  1. .I $G(IBDOK)<0 S IBDOK=0
  1. .I IBDOK S IBDF("APPT")=NEWAPPT(1)
  1. ;
  1. I CNT>1 D
  1. .S DIR("A")=""
  1. .S DIR(0)=""
  1. FNDQ Q