- 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 Jan 18, 2025@03:53:24 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