IBDFFRFT ;ALB/CMR - AICS Free Forms Tracking Entry ; 27-MAR-97
;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38**;APR 24, 1997
;
; -- modified 10/7/97 to allow background freeing via site parameter
;
FREEFT ; -- called to pass data from FT to PCE regardless of whether all
; pages have been received.
;
N FORMTYPE,IBFID,IBD,IBNODE,DFN,CLINIC,APPT,Y,PXCA,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,CNT,ORVP,PXCAVSIT,RESULT,SDFN
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) D FULL^VALM1 S IBD=0 F S IBD=$O(VALMY(IBD)) Q:'IBD!$D(DIRUT) D
.S IBFID=$P($G(^TMP("FRMIDX",$J,+IBD)),"^",2)
.S IBNODE=$G(^IBD(357.96,+IBFID,0)) I IBNODE="" W !,"No Form Tracking record associated with entry #",IBD H 2 Q
.I '$D(^XUSEC("IBD MANAGER",DUZ)) W !,"You must hold the IBD MANAGER key to free Forms Tracking entries" H 2 Q
.I $P(IBNODE,"^",11)'=11 W !,"You may only pass data to PCE if the current status is PENDING PAGES" H 2 Q
.S DFN=$P(IBNODE,"^",2),APPT=$P(IBNODE,"^",3),CLINIC=$P(IBNODE,"^",10)
.;
.; -- display ft data
.W !!,"PATIENT: ",$P($G(^DPT(DFN,0)),"^")," APPT DATE/TIME: ",$$FMTE^XLFDT(APPT,2),!,"CLINIC: ",$P($G(^SC(CLINIC,0)),"^"),!
.;
.; -- display page data
.S I=0 F S I=$O(^IBD(357.96,IBFID,9,I)) Q:'I S IBNODE=$G(^IBD(357.96,IBFID,9,I,0)) W !?5,"Page ",$P(IBNODE,"^")," ",$S(+$P(IBNODE,"^",2):"Received",1:"Not Received")
.W ! S DIR(0)="Y",DIR("A")="Okay to continue",DIR("B")="Y" D ^DIR K DIR Q:'Y
.D SEND(IBFID)
;
D EXIT1^IBDFFT,START^IBDFFT1
S VALMBCK="R"
Q
;
SEND(IBFID,ERRCNT) ; -- send all page data in forms tracking
;
; -- gather data from previously stored pages
S I=0 F S I=$O(^IBD(357.96,IBFID,10,I)) Q:'I D ARYAD^IBDFBKR($G(^IBD(357.96,IBFID,10,I,0)))
;
; -- send data to pce
W:'$D(ZTQUEUED) !,"Sending Data to PCE..."
S RESULT=$$SEND^IBDF18E(IBFID,"","",.BUBBLES,.HANDPRNT,"",.PXCA,.DYNAMIC)
W:'$D(ZTQUEUED) $S(RESULT:"Successfull",1:"Unsuccessful")
;
; -- process any returned errors/warnings
I $D(PXCA("ERROR"))!($D(PXCA("WARNING"))) D
.N I,J,ERR,LCNT,DIR,DIRUT,DUOUT
.S LCNT=0,ERRCNT=$G(ERRCNT)+1
.D EW^IBDFBK2(.ERR,.PXCA,.LCNT)
.;
.W:'$D(ZTQUEUED) !!!,"The following Error(s) occurred while validating data in PCE for: ",$P($G(^DPT(DFN,0)),"^")
.Q:$D(ZTQUEUED)
.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
;
BCKGRND ; -- entry point for back ground job to process pending pages
;
N DAYS,START,END
S DAYS=+$P($G(^IBD(357.09,1,0)),"^",11)
;
Q:'DAYS
S ERRCNT=0
S START=DAYS+7
S START=$$FMADD^XLFDT(DT,-START)
S END=$$FMADD^XLFDT(DT,-DAYS)+.24
;
B1 N CNT,ERRCNT,IBFID,STATUS
F S START=$O(^IBD(357.96,"D",START)) Q:'START!(START>END) D
.S IBFID=0
.F S IBFID=$O(^IBD(357.96,"D",START,IBFID)) Q:'IBFID D
..S STATUS=$P($G(^IBD(357.96,IBFID,0)),"^",11)
..I STATUS=11 S CNT=$G(CNT)+1 D SEND(IBFID,.ERRCNT)
;
D:$G(MANUAL) BULL
I $D(ZTQUEUED),$G(MANUAL) S ZTREQ="@"
Q
;
BULL ; -- add bulletin or something to let people know what was done
; but only if they ask for it during testing.
;
S IBD(1)="The background job to release pending pages has completed"
S IBD(2)=""
S IBD(3)=" Number of Forms Tracking Entries: "_+$G(CNT)
S IBD(4)=" Number of Forms Generating Errors: "_+$G(ERRCNT)
S XMSUB="AICS RELEASE PENDING PAGES"
S XMDUZ="AICS PACKAGE",XMTEXT="IBD("
K XMY S XMN=0
S XMY(DUZ)=""
D ^XMD
K X,Y,IBD,XMDUZ,XMTEXT,XMY,XMSUB,XMN
Q
;
MANUAL ; -- entry point for sending pending pages to PCE for a date range
; get date range and do b1
;
W !!,"Option to Manually send Encounter Forms in a Pending Pages Status in Forms"
W !,"Tracking to PCE by Encounter date range.",!!
;
S MANUAL=1
S DAYS=+$P($G(^IBD(357.09,1,0)),"^",11)
S HELP="Enter a START date. This is an exact date and should be in the past."
S START=$$ASKDT("Start Date: ","T-"_(60+DAYS),"AEPQX","",DT,.HELP,"D SHELP^IBDFFRFT")
I START<1 G MQ
S HELP="Enter the END date. This must be after the start date an before today."
S END=$$ASKDT("End Date: ","T-"_$S(DAYS:DAYS,1:15),"AEQX",START,DT,.HELP,"D EHELP^IBDFFRFT")
I END<1!(END<START) G MQ
S ZTRTN="B1^IBDFFRFT",ZTSAVE("START")="",ZTSAVE("END")="",ZTSAVE("DAYS")="",ZTSAVE("MANUAL")=""
S ZTDESC="IBD-FREE FORMS TRACKING OF PENDING PAGES"
S ZTIO=""
W !!,"This option must be queued. No Device is Necessary."
W !,"A mail message will be sent when the process has completed.",!!
D ^%ZTLOAD
MQ K X,Y,IBD,DAYS,START,END,MANUAL,HELP,ZTSK,ZTRTN,ZTSAVE,ZTSAVE,ZTDESC,ZTIO
Q
;
EHELP ; -- help for the end date prompt
W !,"Enter the END date. This is an Encounter Date."
W !,"This is the last date that forms that are in a Pending Pages Status in Forms"
W !,"Tracking will be automatically sent to PCE for processing."
Q
;
SHELP ; -- help for start date prompt
W !,"Enter the START date. This is an Encounter Date."
W !,"This is the date that you want to start the process that sends forms that"
W !,"are in a Pending Pages Status in Forms Tracking entries to PCE to start on."
Q
;
ASKDT(QUES,DEFLT,PARAM,EARLY,LATEST,HELP,EXHELP) ; -- ask date questions
N X,Y,DIR,DIRUT,DTOUT,DUOUT,IBQUIT
S DIR(0)="DOA^"_$E($G(EARLY),1,7)_":"_$G(LATEST)_":"_$S($G(PARAM)'="":PARAM,1:"AEQRX")
I $G(QUES)'="" S DIR("A")=QUES
I $G(DEFLT)'="" S DIR("B")=DEFLT
I $L($G(EXHELP)) S DIR("??")="^"_EXHELP
I $D(HELP) M DIR("?")=HELP
D ^DIR
I $D(DIRUT),Y'="" S Y=-1 ;i y="" user typed "@"
I $D(DTOUT)!($D(DUOUT)) S IBQUIT=1,Y=-1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFFRFT 5545 printed Sep 23, 2025@20:28:34 Page 2
IBDFFRFT ;ALB/CMR - AICS Free Forms Tracking Entry ; 27-MAR-97
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38**;APR 24, 1997
+2 ;
+3 ; -- modified 10/7/97 to allow background freeing via site parameter
+4 ;
FREEFT ; -- called to pass data from FT to PCE regardless of whether all
+1 ; pages have been received.
+2 ;
+3 NEW FORMTYPE,IBFID,IBD,IBNODE,DFN,CLINIC,APPT,Y,PXCA,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,CNT,ORVP,PXCAVSIT,RESULT,SDFN
+4 DO EN^VALM2($GET(XQORNOD(0)))
+5 IF $DATA(VALMY)
DO FULL^VALM1
SET IBD=0
FOR
SET IBD=$ORDER(VALMY(IBD))
if 'IBD!$DATA(DIRUT)
QUIT
Begin DoDot:1
+6 SET IBFID=$PIECE($GET(^TMP("FRMIDX",$JOB,+IBD)),"^",2)
+7 SET IBNODE=$GET(^IBD(357.96,+IBFID,0))
IF IBNODE=""
WRITE !,"No Form Tracking record associated with entry #",IBD
HANG 2
QUIT
+8 IF '$DATA(^XUSEC("IBD MANAGER",DUZ))
WRITE !,"You must hold the IBD MANAGER key to free Forms Tracking entries"
HANG 2
QUIT
+9 IF $PIECE(IBNODE,"^",11)'=11
WRITE !,"You may only pass data to PCE if the current status is PENDING PAGES"
HANG 2
QUIT
+10 SET DFN=$PIECE(IBNODE,"^",2)
SET APPT=$PIECE(IBNODE,"^",3)
SET CLINIC=$PIECE(IBNODE,"^",10)
+11 ;
+12 ; -- display ft data
+13 WRITE !!,"PATIENT: ",$PIECE($GET(^DPT(DFN,0)),"^")," APPT DATE/TIME: ",$$FMTE^XLFDT(APPT,2),!,"CLINIC: ",$PIECE($GET(^SC(CLINIC,0)),"^"),!
+14 ;
+15 ; -- display page data
+16 SET I=0
FOR
SET I=$ORDER(^IBD(357.96,IBFID,9,I))
if 'I
QUIT
SET IBNODE=$GET(^IBD(357.96,IBFID,9,I,0))
WRITE !?5,"Page ",$PIECE(IBNODE,"^")," ",$SELECT(+$PIECE(IBNODE,"^",2):"Received",1:"Not Received")
+17 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Okay to continue"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
if 'Y
QUIT
+18 DO SEND(IBFID)
End DoDot:1
+19 ;
+20 DO EXIT1^IBDFFT
DO START^IBDFFT1
+21 SET VALMBCK="R"
+22 QUIT
+23 ;
SEND(IBFID,ERRCNT) ; -- send all page data in forms tracking
+1 ;
+2 ; -- gather data from previously stored pages
+3 SET I=0
FOR
SET I=$ORDER(^IBD(357.96,IBFID,10,I))
if 'I
QUIT
DO ARYAD^IBDFBKR($GET(^IBD(357.96,IBFID,10,I,0)))
+4 ;
+5 ; -- send data to pce
+6 if '$DATA(ZTQUEUED)
WRITE !,"Sending Data to PCE..."
+7 SET RESULT=$$SEND^IBDF18E(IBFID,"","",.BUBBLES,.HANDPRNT,"",.PXCA,.DYNAMIC)
+8 if '$DATA(ZTQUEUED)
WRITE $SELECT(RESULT:"Successfull",1:"Unsuccessful")
+9 ;
+10 ; -- process any returned errors/warnings
+11 IF $DATA(PXCA("ERROR"))!($DATA(PXCA("WARNING")))
Begin DoDot:1
+12 NEW I,J,ERR,LCNT,DIR,DIRUT,DUOUT
+13 SET LCNT=0
SET ERRCNT=$GET(ERRCNT)+1
+14 DO EW^IBDFBK2(.ERR,.PXCA,.LCNT)
+15 ;
+16 if '$DATA(ZTQUEUED)
WRITE !!!,"The following Error(s) occurred while validating data in PCE for: ",$PIECE($GET(^DPT(DFN,0)),"^")
+17 if $DATA(ZTQUEUED)
QUIT
+18 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)
+19 WRITE !!
End DoDot:1
+20 QUIT
+21 ;
BCKGRND ; -- entry point for back ground job to process pending pages
+1 ;
+2 NEW DAYS,START,END
+3 SET DAYS=+$PIECE($GET(^IBD(357.09,1,0)),"^",11)
+4 ;
+5 if 'DAYS
QUIT
+6 SET ERRCNT=0
+7 SET START=DAYS+7
+8 SET START=$$FMADD^XLFDT(DT,-START)
+9 SET END=$$FMADD^XLFDT(DT,-DAYS)+.24
+10 ;
B1 NEW CNT,ERRCNT,IBFID,STATUS
+1 FOR
SET START=$ORDER(^IBD(357.96,"D",START))
if 'START!(START>END)
QUIT
Begin DoDot:1
+2 SET IBFID=0
+3 FOR
SET IBFID=$ORDER(^IBD(357.96,"D",START,IBFID))
if 'IBFID
QUIT
Begin DoDot:2
+4 SET STATUS=$PIECE($GET(^IBD(357.96,IBFID,0)),"^",11)
+5 IF STATUS=11
SET CNT=$GET(CNT)+1
DO SEND(IBFID,.ERRCNT)
End DoDot:2
End DoDot:1
+6 ;
+7 if $GET(MANUAL)
DO BULL
+8 IF $DATA(ZTQUEUED)
IF $GET(MANUAL)
SET ZTREQ="@"
+9 QUIT
+10 ;
BULL ; -- add bulletin or something to let people know what was done
+1 ; but only if they ask for it during testing.
+2 ;
+3 SET IBD(1)="The background job to release pending pages has completed"
+4 SET IBD(2)=""
+5 SET IBD(3)=" Number of Forms Tracking Entries: "_+$GET(CNT)
+6 SET IBD(4)=" Number of Forms Generating Errors: "_+$GET(ERRCNT)
+7 SET XMSUB="AICS RELEASE PENDING PAGES"
+8 SET XMDUZ="AICS PACKAGE"
SET XMTEXT="IBD("
+9 KILL XMY
SET XMN=0
+10 SET XMY(DUZ)=""
+11 DO ^XMD
+12 KILL X,Y,IBD,XMDUZ,XMTEXT,XMY,XMSUB,XMN
+13 QUIT
+14 ;
MANUAL ; -- entry point for sending pending pages to PCE for a date range
+1 ; get date range and do b1
+2 ;
+3 WRITE !!,"Option to Manually send Encounter Forms in a Pending Pages Status in Forms"
+4 WRITE !,"Tracking to PCE by Encounter date range.",!!
+5 ;
+6 SET MANUAL=1
+7 SET DAYS=+$PIECE($GET(^IBD(357.09,1,0)),"^",11)
+8 SET HELP="Enter a START date. This is an exact date and should be in the past."
+9 SET START=$$ASKDT("Start Date: ","T-"_(60+DAYS),"AEPQX","",DT,.HELP,"D SHELP^IBDFFRFT")
+10 IF START<1
GOTO MQ
+11 SET HELP="Enter the END date. This must be after the start date an before today."
+12 SET END=$$ASKDT("End Date: ","T-"_$SELECT(DAYS:DAYS,1:15),"AEQX",START,DT,.HELP,"D EHELP^IBDFFRFT")
+13 IF END<1!(END<START)
GOTO MQ
+14 SET ZTRTN="B1^IBDFFRFT"
SET ZTSAVE("START")=""
SET ZTSAVE("END")=""
SET ZTSAVE("DAYS")=""
SET ZTSAVE("MANUAL")=""
+15 SET ZTDESC="IBD-FREE FORMS TRACKING OF PENDING PAGES"
+16 SET ZTIO=""
+17 WRITE !!,"This option must be queued. No Device is Necessary."
+18 WRITE !,"A mail message will be sent when the process has completed.",!!
+19 DO ^%ZTLOAD
MQ KILL X,Y,IBD,DAYS,START,END,MANUAL,HELP,ZTSK,ZTRTN,ZTSAVE,ZTSAVE,ZTDESC,ZTIO
+1 QUIT
+2 ;
EHELP ; -- help for the end date prompt
+1 WRITE !,"Enter the END date. This is an Encounter Date."
+2 WRITE !,"This is the last date that forms that are in a Pending Pages Status in Forms"
+3 WRITE !,"Tracking will be automatically sent to PCE for processing."
+4 QUIT
+5 ;
SHELP ; -- help for start date prompt
+1 WRITE !,"Enter the START date. This is an Encounter Date."
+2 WRITE !,"This is the date that you want to start the process that sends forms that"
+3 WRITE !,"are in a Pending Pages Status in Forms Tracking entries to PCE to start on."
+4 QUIT
+5 ;
ASKDT(QUES,DEFLT,PARAM,EARLY,LATEST,HELP,EXHELP) ; -- ask date questions
+1 NEW X,Y,DIR,DIRUT,DTOUT,DUOUT,IBQUIT
+2 SET DIR(0)="DOA^"_$EXTRACT($GET(EARLY),1,7)_":"_$GET(LATEST)_":"_$SELECT($GET(PARAM)'="":PARAM,1:"AEQRX")
+3 IF $GET(QUES)'=""
SET DIR("A")=QUES
+4 IF $GET(DEFLT)'=""
SET DIR("B")=DEFLT
+5 IF $LENGTH($GET(EXHELP))
SET DIR("??")="^"_EXHELP
+6 IF $DATA(HELP)
MERGE DIR("?")=HELP
+7 DO ^DIR
+8 ;i y="" user typed "@"
IF $DATA(DIRUT)
IF Y'=""
SET Y=-1
+9 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBQUIT=1
SET Y=-1
+10 QUIT Y
