- IBDFDE ;ALB/AAS - AICS Data Entry, Entry point by form ; 24-FEB-96
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,51**;APR 24, 1997
- ;
- W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
- ;
- % 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
- N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDOK,IBD,IBDCKOUT
- N ANS1,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
- ;
- I '$D(DT) D DT^DICRW
- D HOME^%ZIS
- W !!,"Data Entry of Encounter Forms (by Form)",!!
- ;
- STRT ; -- ask for form id
- D END
- S DIR("?")="Enter the encounter form id, printed on the form. This is the second number from the left, just right of the label 'ID:'."
- S DIR(0)="PO^357.96:AEQM",DIR("A")="Encounter Form ID" D ^DIR K DIR,DA,DR,DIC
- I $D(DIRUT) G END
- S IBDF("FORM")=+Y
- D EN
- ;
- STRTQ I '$P($G(^IBD(357.09,1,0)),"^",6) D PAUSE
- G:IBQUIT END
- W @IOF
- Q:$G(IBDF("OPTION"))
- G STRT
- ;
- EN ; -- entry point to edit one form,
- ; Input IBDF("FORM") := form number
- ;
- D:$D(XRTL) T0^%ZOSV
- N IBDSTRT,IBDFIN,IBDTIME S IBDSTRT=$H
- S IBQUIT=0
- L +^IBD(357.96,IBDF("FORM")):5 I '$T W !!,"Form is currently being entered by another user, try again later!" S IBFLAG=1 G ENQ
- I $G(^IBD(357.96,IBDF("FORM"),0))="" W !!,"Form Tracking Entry has been deleted, Data entry not available" S IBFLAG=1 G ENQ
- ;
- OVER ; -- start here to re-edit an entry
- N IOINHI,IOINORM
- S X="IOINHI;IOINORM" D ENDR^%ZISS
- S (IBQUIT,IBDF("KILL"))=0
- D IDPAT^IBDFRPC3(.FRMDATA,IBDF("FORM"))
- D EXPAND(FRMDATA)
- I $P($G(^IBE(357,IBDFMIEN,0)),"^",12)'=1 W !!,"Form is not scannable. Data entry not available" S IBFLAG=1 G ENQ
- ;
- I '$G(IBDF("FRMDEF")) W !!,"Form Definition entry not defined for form tracking entry.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
- I $G(^IBD(357.95,+$G(IBDF("FRMDEF")),0))="" W !!,"Form Definition Entry has been deleted.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
- I $P($G(^IBD(357.95,+$G(IBDF("FRMDEF")),0)),"^",21)="" W !!,"Can not determine Encounter Form from Form Tracking entry.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
- I $G(^IBE(357,IBDFMIEN,0))="" W !!,"Encounter Form has been deleted. Data entry not available." D ERR S IBFLAG=1 G ENQ
- I $G(^DPT(DFN,"S",IBDF("APPT"),0))'="",$P(^DPT(DFN,"S",IBDF("APPT"),0),"^",1)'=IBDF("CLINIC") W !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled.",!,"Data entry not available." S IBFLAG=1 G ENQ
- S X=$P($G(^DPT(DFN,"S",IBDF("APPT"),0)),"^",2) I X'="","^C^N^NA^CA^PC^PCA^"[("^"_X_"^") W !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled or no-showed.",!,"Data entry not available." S IBFLAG=1 G ENQ
- I '$P($G(^IBE(357,IBDFMIEN,0)),"^",5),'$G(IBDREDIT) D KILLTMP
- I '$G(IBDREDIT) D HDR
- ;
- I IBDFMSTI=3!(IBDFMSTI=6) D I IBQUIT G ENQ ; -- already sent to pce
- .Q:$G(IBDREDIT)
- .S IBQUIT=1
- .W !!,"Current form Status is ",IBDFMSTE
- .W:'IBDCKOUT "."
- .W:IBDCKOUT " and was checked out",!,"on "_$$FMTE^XLFDT(IBDCKOUT)_", Status is "_$G(IOINHI)_IBDPTSTE_$G(IOINORM)_".",!
- .S DIR("?")="Data Entry on this form appears to have been completed by either scanning or data entry. Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another form."
- .S DIR("?",1)="Enter ?? to see a list of data stored in PCE."
- .S DIR("?",2)=" "
- .S DIR("??")="^D WRITE^IBDFRPC5"
- .S DIR(0)="Y",DIR("B")="No",DIR("A")="Are you sure you want to continue"
- .D ^DIR K DIR I Y=1 S IBQUIT=0
- ;
- I +IBDCKOUT>0 D I IBQUIT G ENQ ; -- already sent to pce
- .I IBDFMSTI=3!(IBDFMSTI=6) Q
- .Q:$G(IBDREDIT)
- .S IBQUIT=1
- .W !!,"Appointment has already been Checked Out on "_$$FMTE^XLFDT(IBDCKOUT)_",",!,"Status is: "_$G(IOINHI)_IBDPTSTE_$G(IOINORM)_".",!
- .S DIR("?")="This appointment appears to have been checked out on "_$$FMTE^XLFDT(IBDCKOUT)_". Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another form."
- .S DIR("?",1)="Enter ?? to see a list of data stored in PCE."
- .S DIR("?",2)=" "
- .S DIR("??")="^D WRITE^IBDFRPC5"
- .S DIR(0)="Y",DIR("B")="No",DIR("A")="Are you sure you want to continue"
- .D ^DIR K DIR I Y=1 S IBQUIT=0
- ;
- I '$G(IBDREDIT),$G(^DPT(DFN,"S",IBDF("APPT"),0))="" S IBDOK=1 D FNDAPPT^IBDFDE1 I 'IBDOK W !!,"No action Taken",! G ENQ
- ;
- I '$D(^TMP("IBD-OBJ",$J,IBDFMIEN,0)) D FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
- I $O(^TMP("IBD-OBJ",$J,IBDFMIEN,0))="" W !,$G(^TMP("IBD-OBJ",$J,IBDFMIEN,0)),! G ENQ
- ;
- NEWOVER ; -- start here to re-edit an entry
- I $G(IBDREDIT) D HDR
- D LISTOB
- D CHKOUT^IBDFDE0(IBDF("SDOE"))
- I '$G(IBDF("PROVIDER PI"))!($G(IBDF("PROVIDER"))) D DEFPROV^IBDFDE21
- ;
- K ^TMP("IBD-PI-CNT",$J)
- S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I="" D
- .S X=$P($G(^TMP("IBD-OBJ",$J,IBDFMIEN,I)),"^",2)
- .S ^TMP("IBD-PI-CNT",$J,X)=$G(^TMP("IBD-PI-CNT",$J,X))+1
- ;
- S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I=""!(IBQUIT) D
- .S IBDOBJ=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
- .S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
- .S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
- .S IBDF("PAGE")=$P(IBDOBJ,"^",10)\80+1 ;scannable forms only
- .Q:IBDF("IEN")<1!(IBDF("PI")<1)
- .S IBDF("IBDF")=I
- .S RTN=$G(^IBE(357.6,IBDF("PI"),18)) Q:RTN=""
- .X RTN
- .I $G(IBDF("GOTO"))'="" S I=IBDF("GOTO") K IBDF("GOTO")
- K ^TMP("IBD-PI-CNT",$J)
- D FINAL^IBDFDE1 I $G(IBDREDIT) S IBQUIT=0 G OVER
- S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV
- ;
- ENQ K SDFN
- L -^IBD(357.96,IBDF("FORM"))
- I $D(IBFLAG) D
- .I $P($G(^IBD(357.09,1,0)),"^",6) W !! D PAUSE
- .K IBFLAG
- Q
- ;
- HDR ; -- print patient header
- W @IOF
- W IBDPTNM,?32,IBDPID,?47,$$FMTE^XLFDT($P($G(^DPT(DFN,0)),"^",3))
- W " Form ID: ",$P(^IBD(357.96,IBDF("FORM"),0),"^")
- W !,$TR($J(" ",IOM)," ","=")
- W !," Clinic: ",$E(IBDCLNME,1,25) W ?40," Date/Time: ",IBDPTDTE
- W !," Form Name: ",$E(IBDFMNME,1,25) W ?40,"Form Status: ",$E(IBDFMSTE,1,25)
- Q
- ;
- LISTOB ; -- header for input object list
- W !!,"Items available for Input:"
- D WRITE^IBDFDE0(IBDF("SDOE"))
- S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I="" D
- .S X=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
- .Q:'$P(X,"^",8)
- .S Y=$S($P(X,"^",7)="":$P(X,"^"),1:$P(X,"^",7))
- .I Y="INPUT PROVIDER" S IBDF("PROVIDER PI")=+$P(X,"^",2)
- .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
- .W !?3,$E(Y,1,35)
- .;
- .F S I=I+1 S X=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:X=""!($P(X,"^",8))
- .Q:X=""
- .S Y=$S($P(X,"^",7)="":$P(X,"^"),1:$P(X,"^",7))
- .I Y="INPUT PROVIDER" S IBDF("PROVIDER PI")=+$P(X,"^",2)
- .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
- .W ?40,$E(Y,1,35)
- ;
- W !,$TR($J(" ",IOM)," ","=")
- Q
- ;
- EXPAND(X) ; -- sets standard varibles for form data
- S (DFN,IBDF("DFN"))=$P(X,"^",2) ;DFN
- S IBDF("CLINIC")=$P(X,"^",7) ; clinic ien
- S IBDPTNM=$P(X,"^") ; patient name
- S IBDPID=$P(X,"^",3) ; Patient identifier (ssn)
- S IBDFMNME=$P(X,"^",4) ; form name
- S IBDFMIEN=$P(X,"^",5) ; form ien (pointer to 357)
- S IBDCLNME=$P(X,"^",6) ; clinic name
- S IBDCLNPH=$P(X,"^",8) ; clinic physical location
- S IBDF("APPT")=$P(X,"^",9) ; appt date/time (fm format)
- S IBDPTDTE=$P(X,"^",10) ;appt date (external format)
- S IBDPTSTI=$P(X,"^",11) ;appt status (piece two of "S" node)
- S IBDPTSTE=$P(X,"^",12) ;appt status expanded
- S IBDFMSTI=$P(X,"^",13) ;form status (internal)
- S IBDFMSTE=$P(X,"^",14) ;form status (expanded)
- S IBDF("FRMDEF")=$P(X,"^",15) ;form id (pointer to 357.95)
- S IBDPTPRI=$P(X,"^",16) ;default provider internal
- S IBDPTPRI=$P(X,"^",17) ;default provider external
- S IBDCKOUT=$P(X,"^",20) ;checkout dt
- S IBDF("SDOE")=$$FNDSDOE(DFN,IBDF("APPT")) ;outpatient encounter
- Q
- ;Q $$GETAPT^SDVSIT2(DFN,APPT,IBDF("CLINIC"))
- ; -- will create encounters for appts/unsch vsts (but not disps or ae?)
- ;
- FNDSDOE(DFN,APPT) ; -- returns pointer to opt encounter for appt.
- N SDOE
- S SDOE=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",20)
- I SDOE="",$G(^DPT(+$G(DFN),"S",+$G(APPT),0))="" S SDOE=$P($$SDV^IBDFRPC3(DFN,APPT),"^",2)
- Q SDOE
- ;
- PAUSE ; -- go to bottom of screen and pause for return
- Q:$G(IBQUIT)
- N I,DIR,DIRUT,DUOUT,DTOUT I $Y'>(IOSL-3) W !!
- I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR S IBQUIT='Y
- Q
- ;
- END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
- K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
- Q
- ;
- KILLTMP K ^TMP("IBD-OBJ",$J,IBDFMIEN),^TMP("IBD-LST",$J,IBDFMIEN),^TMP("IBD-ASK",$J,IBDFMIEN),^TMP("IB",$J,"INTERFACES"),^TMP("IBD-LTEXT",$J,IBDFMIEN),^TMP("IBD-LCODE",$J,IBDFMIEN)
- Q
- ;
- ERR ;
- W !!,"Entry in Form Tracking file (357.96) = ",$S($G(IBDF("FORM"))'="":IBDF("FORM"),1:"NULL")
- W !," Entry in Form Definition (357.95) = ",$S($G(IBDF("FRMDEF"))'="":IBDF("FRMDEF"),1:"NULL")
- W !," Entry if Encounter Form file (357) = ",$S($G(IBDFMIEN)'="":IBDFMIEN,1:"NULL"),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE 9182 printed Feb 19, 2025@00:18:36 Page 2
- IBDFDE ;ALB/AAS - AICS Data Entry, Entry point by form ; 24-FEB-96
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,51**;APR 24, 1997
- +2 ;
- +3 ;Code set Versioning
- WRITE !,?4,"** This option is OUT OF ORDER **"
- QUIT
- +4 ;
- % NEW %,%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
- +1 NEW IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDOK,IBD,IBDCKOUT
- +2 NEW ANS1,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
- +3 ;
- +4 IF '$DATA(DT)
- DO DT^DICRW
- +5 DO HOME^%ZIS
- +6 WRITE !!,"Data Entry of Encounter Forms (by Form)",!!
- +7 ;
- STRT ; -- ask for form id
- +1 DO END
- +2 SET DIR("?")="Enter the encounter form id, printed on the form. This is the second number from the left, just right of the label 'ID:'."
- +3 SET DIR(0)="PO^357.96:AEQM"
- SET DIR("A")="Encounter Form ID"
- DO ^DIR
- KILL DIR,DA,DR,DIC
- +4 IF $DATA(DIRUT)
- GOTO END
- +5 SET IBDF("FORM")=+Y
- +6 DO EN
- +7 ;
- STRTQ IF '$PIECE($GET(^IBD(357.09,1,0)),"^",6)
- DO PAUSE
- +1 if IBQUIT
- GOTO END
- +2 WRITE @IOF
- +3 if $GET(IBDF("OPTION"))
- QUIT
- +4 GOTO STRT
- +5 ;
- EN ; -- entry point to edit one form,
- +1 ; Input IBDF("FORM") := form number
- +2 ;
- +3 if $DATA(XRTL)
- DO T0^%ZOSV
- +4 NEW IBDSTRT,IBDFIN,IBDTIME
- SET IBDSTRT=$HOROLOG
- +5 SET IBQUIT=0
- +6 LOCK +^IBD(357.96,IBDF("FORM")):5
- IF '$TEST
- WRITE !!,"Form is currently being entered by another user, try again later!"
- SET IBFLAG=1
- GOTO ENQ
- +7 IF $GET(^IBD(357.96,IBDF("FORM"),0))=""
- WRITE !!,"Form Tracking Entry has been deleted, Data entry not available"
- SET IBFLAG=1
- GOTO ENQ
- +8 ;
- OVER ; -- start here to re-edit an entry
- +1 NEW IOINHI,IOINORM
- +2 SET X="IOINHI;IOINORM"
- DO ENDR^%ZISS
- +3 SET (IBQUIT,IBDF("KILL"))=0
- +4 DO IDPAT^IBDFRPC3(.FRMDATA,IBDF("FORM"))
- +5 DO EXPAND(FRMDATA)
- +6 IF $PIECE($GET(^IBE(357,IBDFMIEN,0)),"^",12)'=1
- WRITE !!,"Form is not scannable. Data entry not available"
- SET IBFLAG=1
- GOTO ENQ
- +7 ;
- +8 IF '$GET(IBDF("FRMDEF"))
- WRITE !!,"Form Definition entry not defined for form tracking entry.",!,"Data entry not available."
- DO ERR
- SET IBFLAG=1
- GOTO ENQ
- +9 IF $GET(^IBD(357.95,+$GET(IBDF("FRMDEF")),0))=""
- WRITE !!,"Form Definition Entry has been deleted.",!,"Data entry not available."
- DO ERR
- SET IBFLAG=1
- GOTO ENQ
- +10 IF $PIECE($GET(^IBD(357.95,+$GET(IBDF("FRMDEF")),0)),"^",21)=""
- WRITE !!,"Can not determine Encounter Form from Form Tracking entry.",!,"Data entry not available."
- DO ERR
- SET IBFLAG=1
- GOTO ENQ
- +11 IF $GET(^IBE(357,IBDFMIEN,0))=""
- WRITE !!,"Encounter Form has been deleted. Data entry not available."
- DO ERR
- SET IBFLAG=1
- GOTO ENQ
- +12 IF $GET(^DPT(DFN,"S",IBDF("APPT"),0))'=""
- IF $PIECE(^DPT(DFN,"S",IBDF("APPT"),0),"^",1)'=IBDF("CLINIC")
- WRITE !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled.",!,"Data entry not available."
- SET IBFLAG=1
- GOTO ENQ
- +13 SET X=$PIECE($GET(^DPT(DFN,"S",IBDF("APPT"),0)),"^",2)
- IF X'=""
- IF "^C^N^NA^CA^PC^PCA^"[("^"_X_"^")
- WRITE !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled or no-showed.",!,"Data entry not available."
- SET IBFLAG=1
- GOTO ENQ
- +14 IF '$PIECE($GET(^IBE(357,IBDFMIEN,0)),"^",5)
- IF '$GET(IBDREDIT)
- DO KILLTMP
- +15 IF '$GET(IBDREDIT)
- DO HDR
- +16 ;
- +17 ; -- already sent to pce
- IF IBDFMSTI=3!(IBDFMSTI=6)
- Begin DoDot:1
- +18 if $GET(IBDREDIT)
- QUIT
- +19 SET IBQUIT=1
- +20 WRITE !!,"Current form Status is ",IBDFMSTE
- +21 if 'IBDCKOUT
- WRITE "."
- +22 if IBDCKOUT
- WRITE " and was checked out",!,"on "_$$FMTE^XLFDT(IBDCKOUT)_", Status is "_$GET(IOINHI)_IBDPTSTE_$GET(IOINORM)_".",!
- +23 SET DIR("?")="Data Entry on this form appears to have been completed by either scanning or data entry. Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another for
- m."
- +24 SET DIR("?",1)="Enter ?? to see a list of data stored in PCE."
- +25 SET DIR("?",2)=" "
- +26 SET DIR("??")="^D WRITE^IBDFRPC5"
- +27 SET DIR(0)="Y"
- SET DIR("B")="No"
- SET DIR("A")="Are you sure you want to continue"
- +28 DO ^DIR
- KILL DIR
- IF Y=1
- SET IBQUIT=0
- End DoDot:1
- IF IBQUIT
- GOTO ENQ
- +29 ;
- +30 ; -- already sent to pce
- IF +IBDCKOUT>0
- Begin DoDot:1
- +31 IF IBDFMSTI=3!(IBDFMSTI=6)
- QUIT
- +32 if $GET(IBDREDIT)
- QUIT
- +33 SET IBQUIT=1
- +34 WRITE !!,"Appointment has already been Checked Out on "_$$FMTE^XLFDT(IBDCKOUT)_",",!,"Status is: "_$GET(IOINHI)_IBDPTSTE_$GET(IOINORM)_".",!
- +35 SET DIR("?")="This appointment appears to have been checked out on "_$$FMTE^XLFDT(IBDCKOUT)_". Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another form."
- +36 SET DIR("?",1)="Enter ?? to see a list of data stored in PCE."
- +37 SET DIR("?",2)=" "
- +38 SET DIR("??")="^D WRITE^IBDFRPC5"
- +39 SET DIR(0)="Y"
- SET DIR("B")="No"
- SET DIR("A")="Are you sure you want to continue"
- +40 DO ^DIR
- KILL DIR
- IF Y=1
- SET IBQUIT=0
- End DoDot:1
- IF IBQUIT
- GOTO ENQ
- +41 ;
- +42 IF '$GET(IBDREDIT)
- IF $GET(^DPT(DFN,"S",IBDF("APPT"),0))=""
- SET IBDOK=1
- DO FNDAPPT^IBDFDE1
- IF 'IBDOK
- WRITE !!,"No action Taken",!
- GOTO ENQ
- +43 ;
- +44 IF '$DATA(^TMP("IBD-OBJ",$JOB,IBDFMIEN,0))
- DO FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
- +45 IF $ORDER(^TMP("IBD-OBJ",$JOB,IBDFMIEN,0))=""
- WRITE !,$GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,0)),!
- GOTO ENQ
- +46 ;
- NEWOVER ; -- start here to re-edit an entry
- +1 IF $GET(IBDREDIT)
- DO HDR
- +2 DO LISTOB
- +3 DO CHKOUT^IBDFDE0(IBDF("SDOE"))
- +4 IF '$GET(IBDF("PROVIDER PI"))!($GET(IBDF("PROVIDER")))
- DO DEFPROV^IBDFDE21
- +5 ;
- +6 KILL ^TMP("IBD-PI-CNT",$JOB)
- +7 SET I=0
- FOR
- SET I=$ORDER(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- if I=""
- QUIT
- Begin DoDot:1
- +8 SET X=$PIECE($GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I)),"^",2)
- +9 SET ^TMP("IBD-PI-CNT",$JOB,X)=$GET(^TMP("IBD-PI-CNT",$JOB,X))+1
- End DoDot:1
- +10 ;
- +11 SET I=0
- FOR
- SET I=$ORDER(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- if I=""!(IBQUIT)
- QUIT
- Begin DoDot:1
- +12 SET IBDOBJ=$GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- +13 SET IBDF("PI")=+$PIECE(IBDOBJ,"^",2)
- SET IBDF("TYPE")=$PIECE(IBDOBJ,"^",5)
- +14 SET IBDF("IEN")=+$PIECE(IBDOBJ,"^",6)
- SET IBDF("VITAL")=$PIECE(IBDOBJ,"^",7)
- +15 ;scannable forms only
- SET IBDF("PAGE")=$PIECE(IBDOBJ,"^",10)\80+1
- +16 if IBDF("IEN")<1!(IBDF("PI")<1)
- QUIT
- +17 SET IBDF("IBDF")=I
- +18 SET RTN=$GET(^IBE(357.6,IBDF("PI"),18))
- if RTN=""
- QUIT
- +19 XECUTE RTN
- +20 IF $GET(IBDF("GOTO"))'=""
- SET I=IBDF("GOTO")
- KILL IBDF("GOTO")
- End DoDot:1
- +21 KILL ^TMP("IBD-PI-CNT",$JOB)
- +22 DO FINAL^IBDFDE1
- IF $GET(IBDREDIT)
- SET IBQUIT=0
- GOTO OVER
- +23 if $DATA(XRT0)
- SET XRTN=$TEXT(+0)
- if $DATA(XRT0)
- DO T1^%ZOSV
- +24 ;
- ENQ KILL SDFN
- +1 LOCK -^IBD(357.96,IBDF("FORM"))
- +2 IF $DATA(IBFLAG)
- Begin DoDot:1
- +3 IF $PIECE($GET(^IBD(357.09,1,0)),"^",6)
- WRITE !!
- DO PAUSE
- +4 KILL IBFLAG
- End DoDot:1
- +5 QUIT
- +6 ;
- HDR ; -- print patient header
- +1 WRITE @IOF
- +2 WRITE IBDPTNM,?32,IBDPID,?47,$$FMTE^XLFDT($PIECE($GET(^DPT(DFN,0)),"^",3))
- +3 WRITE " Form ID: ",$PIECE(^IBD(357.96,IBDF("FORM"),0),"^")
- +4 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","=")
- +5 WRITE !," Clinic: ",$EXTRACT(IBDCLNME,1,25)
- WRITE ?40," Date/Time: ",IBDPTDTE
- +6 WRITE !," Form Name: ",$EXTRACT(IBDFMNME,1,25)
- WRITE ?40,"Form Status: ",$EXTRACT(IBDFMSTE,1,25)
- +7 QUIT
- +8 ;
- LISTOB ; -- header for input object list
- +1 WRITE !!,"Items available for Input:"
- +2 DO WRITE^IBDFDE0(IBDF("SDOE"))
- +3 SET I=0
- FOR
- SET I=$ORDER(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- if I=""
- QUIT
- Begin DoDot:1
- +4 SET X=$GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- +5 if '$PIECE(X,"^",8)
- QUIT
- +6 SET Y=$SELECT($PIECE(X,"^",7)="":$PIECE(X,"^"),1:$PIECE(X,"^",7))
- +7 IF Y="INPUT PROVIDER"
- SET IBDF("PROVIDER PI")=+$PIECE(X,"^",2)
- +8 IF Y["INPUT "
- SET Y=$PIECE(Y,"INPUT ",2)
- +9 WRITE !?3,$EXTRACT(Y,1,35)
- +10 ;
- +11 FOR
- SET I=I+1
- SET X=$GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
- if X=""!($PIECE(X,"^",8))
- QUIT
- +12 if X=""
- QUIT
- +13 SET Y=$SELECT($PIECE(X,"^",7)="":$PIECE(X,"^"),1:$PIECE(X,"^",7))
- +14 IF Y="INPUT PROVIDER"
- SET IBDF("PROVIDER PI")=+$PIECE(X,"^",2)
- +15 IF Y["INPUT "
- SET Y=$PIECE(Y,"INPUT ",2)
- +16 WRITE ?40,$EXTRACT(Y,1,35)
- End DoDot:1
- +17 ;
- +18 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","=")
- +19 QUIT
- +20 ;
- EXPAND(X) ; -- sets standard varibles for form data
- +1 ;DFN
- SET (DFN,IBDF("DFN"))=$PIECE(X,"^",2)
- +2 ; clinic ien
- SET IBDF("CLINIC")=$PIECE(X,"^",7)
- +3 ; patient name
- SET IBDPTNM=$PIECE(X,"^")
- +4 ; Patient identifier (ssn)
- SET IBDPID=$PIECE(X,"^",3)
- +5 ; form name
- SET IBDFMNME=$PIECE(X,"^",4)
- +6 ; form ien (pointer to 357)
- SET IBDFMIEN=$PIECE(X,"^",5)
- +7 ; clinic name
- SET IBDCLNME=$PIECE(X,"^",6)
- +8 ; clinic physical location
- SET IBDCLNPH=$PIECE(X,"^",8)
- +9 ; appt date/time (fm format)
- SET IBDF("APPT")=$PIECE(X,"^",9)
- +10 ;appt date (external format)
- SET IBDPTDTE=$PIECE(X,"^",10)
- +11 ;appt status (piece two of "S" node)
- SET IBDPTSTI=$PIECE(X,"^",11)
- +12 ;appt status expanded
- SET IBDPTSTE=$PIECE(X,"^",12)
- +13 ;form status (internal)
- SET IBDFMSTI=$PIECE(X,"^",13)
- +14 ;form status (expanded)
- SET IBDFMSTE=$PIECE(X,"^",14)
- +15 ;form id (pointer to 357.95)
- SET IBDF("FRMDEF")=$PIECE(X,"^",15)
- +16 ;default provider internal
- SET IBDPTPRI=$PIECE(X,"^",16)
- +17 ;default provider external
- SET IBDPTPRI=$PIECE(X,"^",17)
- +18 ;checkout dt
- SET IBDCKOUT=$PIECE(X,"^",20)
- +19 ;outpatient encounter
- SET IBDF("SDOE")=$$FNDSDOE(DFN,IBDF("APPT"))
- +20 QUIT
- +21 ;Q $$GETAPT^SDVSIT2(DFN,APPT,IBDF("CLINIC"))
- +22 ; -- will create encounters for appts/unsch vsts (but not disps or ae?)
- +23 ;
- FNDSDOE(DFN,APPT) ; -- returns pointer to opt encounter for appt.
- +1 NEW SDOE
- +2 SET SDOE=$PIECE($GET(^DPT(+$GET(DFN),"S",+$GET(APPT),0)),"^",20)
- +3 IF SDOE=""
- IF $GET(^DPT(+$GET(DFN),"S",+$GET(APPT),0))=""
- SET SDOE=$PIECE($$SDV^IBDFRPC3(DFN,APPT),"^",2)
- +4 QUIT SDOE
- +5 ;
- PAUSE ; -- go to bottom of screen and pause for return
- +1 if $GET(IBQUIT)
- QUIT
- +2 NEW I,DIR,DIRUT,DUOUT,DTOUT
- IF $Y'>(IOSL-3)
- WRITE !!
- +3 IF $EXTRACT(IOST,1,2)["C-"
- SET DIR(0)="E"
- DO ^DIR
- SET IBQUIT='Y
- +4 QUIT
- +5 ;
- END KILL I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
- +1 KILL ^TMP("IBD-ASK",$JOB),^TMP("IBD-LCODE",$JOB),^TMP("IBD-LST",$JOB),^TMP("IBD-LTEXT",$JOB),^TMP("IBD-OBJ",$JOB)
- +2 QUIT
- +3 ;
- KILLTMP KILL ^TMP("IBD-OBJ",$JOB,IBDFMIEN),^TMP("IBD-LST",$JOB,IBDFMIEN),^TMP("IBD-ASK",$JOB,IBDFMIEN),^TMP("IB",$JOB,"INTERFACES"),^TMP("IBD-LTEXT",$JOB,IBDFMIEN),^TMP("IBD-LCODE",$JOB,IBDFMIEN)
- +1 QUIT
- +2 ;
- ERR ;
- +1 WRITE !!,"Entry in Form Tracking file (357.96) = ",$SELECT($GET(IBDF("FORM"))'="":IBDF("FORM"),1:"NULL")
- +2 WRITE !," Entry in Form Definition (357.95) = ",$SELECT($GET(IBDF("FRMDEF"))'="":IBDF("FRMDEF"),1:"NULL")
- +3 WRITE !," Entry if Encounter Form file (357) = ",$SELECT($GET(IBDFMIEN)'="":IBDFMIEN,1:"NULL"),!
- +4 QUIT