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 Oct 16, 2024@18:52:56 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
