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