QAC20PST ;ALB/TKW,RRG - POST-INSTALL FOR PATCH QAC*2*20 Repair ROC numbers ;12/06/06 14:30
;;2.0;Patient Representative;**20**;07/25/1995;Build 7
;
;
ENV ; Environment Check
;
Q:'$G(XPDENV)
W ! K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Queue the Post-Install to run at what Date@Time: "
D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!,"Cannot install the patch without queuing the post-install. Install aborted!",! S XPDABORT=2 Q
S @XPDGREF@("QAC20")=Y K DTOUT
Q
;
EN ;
S ZTDTH=@XPDGREF@("QAC20")
S ZTRTN="START^QAC20PST",ZTDESC="Background job to repair ROC numbers",ZTIO="" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
I $D(ZTSK)&('$D(ZTQUEUED)) D BMES^XPDUTL("Task Queued!")
K ZTSK,ZTQUEUED
Q
;
START ;
N PARENT,ROCNO,NEWROC,IEN,QA0,YR,DIR,I,Y,TIME
K ^TMP("QACROCNO",$J)
; Set up mailman message format
N LCNT,LINE,LINE2,MESS,MSG,MSG1
S LCNT=1,$P(LINE,"-",80)="",$P(LINE2,"=",80)=""
K ^TMP($J)
S MESS="Repair ROC numbers",MSG1=" beginning at "
D TIME
S ^TMP($J,"P20",LCNT)="",LCNT=LCNT+1
;
; Find parent station number from QUALITY ASSURANCE SITE PARAMETERS file
S PARENT=$P($G(^QA(740,1,0)),"^"),PARENT=$$STA^XUAF4(PARENT)
I PARENT="" S ^TMP($J,"P20",LCNT)="Cannot find Parent Institution",LCNT=LCNT+1 D XMT Q
;
; Build lists of ROCs with invalid numbers by year.
F I=0:0 S I=$O(^QA(745.1,I)) Q:'I S QA0=$G(^(I,0)),ROCNO=$P(QA0,"^") D
. I ROCNO="" S ^TMP("QACROCNO",$J,I," ")="" Q
. S YR=$E($P(QA0,"^",2),1,3)
. I ($P(ROCNO,".")'=PARENT)!(ROCNO'?3N.AN1"."6N) D
.. S:YR YR(YR)=""
.. S ^TMP("QACROCNO",$J,I,ROCNO)=YR Q
. Q
I '$D(^TMP("QACROCNO",$J)) S ^TMP($J,"P20",LCNT)="No invalid ROC numbers were found.",LCNT=LCNT+1 D XMT Q
;
; Find default 'last sequential number' for ROCs in each year.
S YR=""
F S YR=$O(YR(YR)) Q:YR="" D
. S ROCNO=$O(^QA(745.1,"B",PARENT_"."_$E(YR,2,3)_"9999"),-1)
. I $P(ROCNO,".")=PARENT,$E($P(ROCNO,".",2),1,2)=$E(YR,2,3) S YR(YR)=+$E($P(ROCNO,".",2),3,6) Q
. S YR(YR)=0 Q
;
; Assign a suggested new number for each ROC
F IEN=0:0 S IEN=$O(^TMP("QACROCNO",$J,IEN)) Q:'IEN D
. S ROCNO="" F S ROCNO=$O(^TMP("QACROCNO",$J,IEN,ROCNO)) Q:ROCNO="" D
.. S YR=^TMP("QACROCNO",$J,IEN,ROCNO) Q:YR="" Q:'$D(YR(YR))
.. S I=YR(YR)+1,YR(YR)=I
.. S NEWROC=PARENT_"."_$E(YR,2,3)_$E("000",1,(4-$L(I)))_I
.. S $P(^TMP("QACROCNO",$J,IEN,ROCNO),"^",2)=NEWROC Q
. Q
;
;
FIX ; Repair ROC numbers
N FDA,CNT
S CNT=0
F IEN=0:0 S IEN=$O(^TMP("QACROCNO",$J,IEN)) Q:'IEN D
. S ROCNO="" F S ROCNO=$O(^TMP("QACROCNO",$J,IEN,ROCNO)) Q:ROCNO="" D:ROCNO'=" "
.. S NEWROC=$P(^TMP("QACROCNO",$J,IEN,ROCNO),"^",2) I NEWROC="" S ^TMP($J,"P20",LCNT)="ROC number "_ROCNO_" could not be changed. Please review manually for a missing Date of Contact.",LCNT=LCNT+1 Q
.. S ^TMP($J,"P20",LCNT)="ROC Number changed from "_ROCNO_" to "_NEWROC,LCNT=LCNT+1
.. K FDA S FDA(745.1,IEN_",",.01)=NEWROC
.. D FILE^DIE("","FDA")
.. S CNT=CNT+1
.. Q
. Q
S ^TMP($J,"P20",LCNT)=CNT_" ROC Numbers have been corrected.",LCNT=LCNT+1
D XMT
Q
;
ENRPT ; Setup to print report of invalid ROCs
N ZTSAVE
S ZTSAVE("PATSHDR")=""
D EN^XUTMDEVQ("DQRPT^QAC20PST","Report of Invalid ROCs",.ZTSAVE)
Q
;
DQRPT ; Print report of invalid ROCs
N PAGENO,LNCNT,ROCNO,IEN,NEWROC,HDDATE,%,%H,%I
S PAGENO=1,LNCNT=0
D NOW^%DTC S HDDATE=$$FMTE^XLFDT(%)
U IO D HDR
F IEN=0:0 S IEN=$O(^TMP("QACROCNO",$J,IEN)) Q:'IEN D
. S ROCNO="" F S ROCNO=$O(^TMP("QACROCNO",$J,IEN,ROCNO)) Q:ROCNO="" D
.. D:LNCNT>55 HDR
.. S NEWROC=$P(^TMP("QACROCNO",$J,IEN,ROCNO),"^",2)
.. W !,IEN,?20,$S(ROCNO=" ":"Missing",1:ROCNO),?45,$S(NEWROC="":"Cannot be fixed",1:NEWROC)
.. S LNCNT=LNCNT+1 Q
. Q
Q
;
HDR W #,!,"Report of Invalid ROCs",?43,HDDATE,?68,"Page "_PAGENO,!
W "IEN",?20,"Old ROC Number",?45,"Suggested New ROC Number",!
N X S X="",$P(X,"-",78)=""
W X,!
S LNCNT=0,PAGENO=PAGENO+1 Q
;
TIME ;Get current time
D NOW^%DTC
S Y=%
D DD^%DT
S TIME=Y
Q
;
XMT ;Send report via mail message
I $D(^TMP($J,"P20")) D
. N DIFROM,XMDUZ,XMSUB,XMTEXT,XMY
. S XMDUZ=.5
. S XMSUB="QAC*2*20 POST INSTALL RESULTS"
. S XMTEXT="^TMP($J,""P20"","
. S XMY(DUZ)=""
. D ^XMD
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAC20PST 4209 printed Jan 14, 2021@17:15:23 Page 2
QAC20PST ;ALB/TKW,RRG - POST-INSTALL FOR PATCH QAC*2*20 Repair ROC numbers ;12/06/06 14:30
+1 ;;2.0;Patient Representative;**20**;07/25/1995;Build 7
+2 ;
+3 ;
ENV ; Environment Check
+1 ;
+2 if '$GET(XPDENV)
QUIT
+3 WRITE !
KILL %DT
DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("A")="Queue the Post-Install to run at what Date@Time: "
+4 DO ^%DT
KILL %DT
IF $DATA(DTOUT)!(Y<0)
WRITE !!,"Cannot install the patch without queuing the post-install. Install aborted!",!
SET XPDABORT=2
QUIT
+5 SET @XPDGREF@("QAC20")=Y
KILL DTOUT
+6 QUIT
+7 ;
EN ;
+1 SET ZTDTH=@XPDGREF@("QAC20")
+2 SET ZTRTN="START^QAC20PST"
SET ZTDESC="Background job to repair ROC numbers"
SET ZTIO=""
DO ^%ZTLOAD
KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
+3 IF $DATA(ZTSK)&('$DATA(ZTQUEUED))
DO BMES^XPDUTL("Task Queued!")
+4 KILL ZTSK,ZTQUEUED
+5 QUIT
+6 ;
START ;
+1 NEW PARENT,ROCNO,NEWROC,IEN,QA0,YR,DIR,I,Y,TIME
+2 KILL ^TMP("QACROCNO",$JOB)
+3 ; Set up mailman message format
+4 NEW LCNT,LINE,LINE2,MESS,MSG,MSG1
+5 SET LCNT=1
SET $PIECE(LINE,"-",80)=""
SET $PIECE(LINE2,"=",80)=""
+6 KILL ^TMP($JOB)
+7 SET MESS="Repair ROC numbers"
SET MSG1=" beginning at "
+8 DO TIME
+9 SET ^TMP($JOB,"P20",LCNT)=""
SET LCNT=LCNT+1
+10 ;
+11 ; Find parent station number from QUALITY ASSURANCE SITE PARAMETERS file
+12 SET PARENT=$PIECE($GET(^QA(740,1,0)),"^")
SET PARENT=$$STA^XUAF4(PARENT)
+13 IF PARENT=""
SET ^TMP($JOB,"P20",LCNT)="Cannot find Parent Institution"
SET LCNT=LCNT+1
DO XMT
QUIT
+14 ;
+15 ; Build lists of ROCs with invalid numbers by year.
+16 FOR I=0:0
SET I=$ORDER(^QA(745.1,I))
if 'I
QUIT
SET QA0=$GET(^(I,0))
SET ROCNO=$PIECE(QA0,"^")
Begin DoDot:1
+17 IF ROCNO=""
SET ^TMP("QACROCNO",$JOB,I," ")=""
QUIT
+18 SET YR=$EXTRACT($PIECE(QA0,"^",2),1,3)
+19 IF ($PIECE(ROCNO,".")'=PARENT)!(ROCNO'?3N.AN1"."6N)
Begin DoDot:2
+20 if YR
SET YR(YR)=""
+21 SET ^TMP("QACROCNO",$JOB,I,ROCNO)=YR
QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 IF '$DATA(^TMP("QACROCNO",$JOB))
SET ^TMP($JOB,"P20",LCNT)="No invalid ROC numbers were found."
SET LCNT=LCNT+1
DO XMT
QUIT
+24 ;
+25 ; Find default 'last sequential number' for ROCs in each year.
+26 SET YR=""
+27 FOR
SET YR=$ORDER(YR(YR))
if YR=""
QUIT
Begin DoDot:1
+28 SET ROCNO=$ORDER(^QA(745.1,"B",PARENT_"."_$EXTRACT(YR,2,3)_"9999"),-1)
+29 IF $PIECE(ROCNO,".")=PARENT
IF $EXTRACT($PIECE(ROCNO,".",2),1,2)=$EXTRACT(YR,2,3)
SET YR(YR)=+$EXTRACT($PIECE(ROCNO,".",2),3,6)
QUIT
+30 SET YR(YR)=0
QUIT
End DoDot:1
+31 ;
+32 ; Assign a suggested new number for each ROC
+33 FOR IEN=0:0
SET IEN=$ORDER(^TMP("QACROCNO",$JOB,IEN))
if 'IEN
QUIT
Begin DoDot:1
+34 SET ROCNO=""
FOR
SET ROCNO=$ORDER(^TMP("QACROCNO",$JOB,IEN,ROCNO))
if ROCNO=""
QUIT
Begin DoDot:2
+35 SET YR=^TMP("QACROCNO",$JOB,IEN,ROCNO)
if YR=""
QUIT
if '$DATA(YR(YR))
QUIT
+36 SET I=YR(YR)+1
SET YR(YR)=I
+37 SET NEWROC=PARENT_"."_$EXTRACT(YR,2,3)_$EXTRACT("000",1,(4-$LENGTH(I)))_I
+38 SET $PIECE(^TMP("QACROCNO",$JOB,IEN,ROCNO),"^",2)=NEWROC
QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 ;
+41 ;
FIX ; Repair ROC numbers
+1 NEW FDA,CNT
+2 SET CNT=0
+3 FOR IEN=0:0
SET IEN=$ORDER(^TMP("QACROCNO",$JOB,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET ROCNO=""
FOR
SET ROCNO=$ORDER(^TMP("QACROCNO",$JOB,IEN,ROCNO))
if ROCNO=""
QUIT
if ROCNO'=" "
Begin DoDot:2
+5 SET NEWROC=$PIECE(^TMP("QACROCNO",$JOB,IEN,ROCNO),"^",2)
IF NEWROC=""
SET ^TMP($JOB,"P20",LCNT)="ROC number "_ROCNO_" could not be changed. Please review manually for a missing Date of Contact."
SET LCNT=LCNT+1
QUIT
+6 SET ^TMP($JOB,"P20",LCNT)="ROC Number changed from "_ROCNO_" to "_NEWROC
SET LCNT=LCNT+1
+7 KILL FDA
SET FDA(745.1,IEN_",",.01)=NEWROC
+8 DO FILE^DIE("","FDA")
+9 SET CNT=CNT+1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET ^TMP($JOB,"P20",LCNT)=CNT_" ROC Numbers have been corrected."
SET LCNT=LCNT+1
+13 DO XMT
+14 QUIT
+15 ;
ENRPT ; Setup to print report of invalid ROCs
+1 NEW ZTSAVE
+2 SET ZTSAVE("PATSHDR")=""
+3 DO EN^XUTMDEVQ("DQRPT^QAC20PST","Report of Invalid ROCs",.ZTSAVE)
+4 QUIT
+5 ;
DQRPT ; Print report of invalid ROCs
+1 NEW PAGENO,LNCNT,ROCNO,IEN,NEWROC,HDDATE,%,%H,%I
+2 SET PAGENO=1
SET LNCNT=0
+3 DO NOW^%DTC
SET HDDATE=$$FMTE^XLFDT(%)
+4 USE IO
DO HDR
+5 FOR IEN=0:0
SET IEN=$ORDER(^TMP("QACROCNO",$JOB,IEN))
if 'IEN
QUIT
Begin DoDot:1
+6 SET ROCNO=""
FOR
SET ROCNO=$ORDER(^TMP("QACROCNO",$JOB,IEN,ROCNO))
if ROCNO=""
QUIT
Begin DoDot:2
+7 if LNCNT>55
DO HDR
+8 SET NEWROC=$PIECE(^TMP("QACROCNO",$JOB,IEN,ROCNO),"^",2)
+9 WRITE !,IEN,?20,$SELECT(ROCNO=" ":"Missing",1:ROCNO),?45,$SELECT(NEWROC="":"Cannot be fixed",1:NEWROC)
+10 SET LNCNT=LNCNT+1
QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
HDR WRITE #,!,"Report of Invalid ROCs",?43,HDDATE,?68,"Page "_PAGENO,!
+1 WRITE "IEN",?20,"Old ROC Number",?45,"Suggested New ROC Number",!
+2 NEW X
SET X=""
SET $PIECE(X,"-",78)=""
+3 WRITE X,!
+4 SET LNCNT=0
SET PAGENO=PAGENO+1
QUIT
+5 ;
TIME ;Get current time
+1 DO NOW^%DTC
+2 SET Y=%
+3 DO DD^%DT
+4 SET TIME=Y
+5 QUIT
+6 ;
XMT ;Send report via mail message
+1 IF $DATA(^TMP($JOB,"P20"))
Begin DoDot:1
+2 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY
+3 SET XMDUZ=.5
+4 SET XMSUB="QAC*2*20 POST INSTALL RESULTS"
+5 SET XMTEXT="^TMP($J,""P20"","
+6 SET XMY(DUZ)=""
+7 DO ^XMD
End DoDot:1
+8 ;
