SDSCPRG ;ALB/JAM/RBS - ASCD Purge encounters that have been deleted ; 1/19/07 12:39pm
;;5.3;Scheduling;**495**;Aug 13, 1993;Build 50
;;MODIFIED FOR NATIONAL RELEASE from a Class III software product
;;known as Service Connected Automated Monitoring (SCAM).
;
;**Program Description**
; This program will check to see if an encounter in the
; SD SERVICE CONNECTED CHANGES File (#409.48)
; has been deleted from the OUTPATIENT ENCOUNTER file (#409.68) and
; remove that record from file #409.48.
Q
EN ; Entry point
N SDOE,NOACT,ACT,NCNT,WCNT,DA,DIK,LINE,SDI,SDJ,CNT
K ^TMP("SDSCPRG",$J),^TMP("SDSCPMSG",$J)
S DIK="^SDSC(409.48,",(SDOE,NOACT,ACT)=0,(NCNT,WCNT)=1
F S SDOE=$O(^SDSC(409.48,SDOE)) Q:'SDOE D
. I $$GETOE^SDOE(SDOE)="" D
.. K ATEXT
.. D GETS^DIQ(409.48,SDOE,"**","E","ATEXT")
.. ; Initialize message
.. S ^TMP("SDSCPRG",$J,"NO",1,0)="Encounters with No Action Taken: "_NOACT
.. S ^TMP("SDSCPRG",$J,"WITH",1,0)="Encounters with Actions Taken: "_ACT
.. I $D(ATEXT(409.481))>0 S ACT=ACT+1,^TMP("SDSCPRG",$J,"WITH",1,0)="Encounters with Actions Taken: "_ACT
.. I $D(ATEXT(409.481))'>0 D Q
... S NOACT=NOACT+1,^TMP("SDSCPRG",$J,"NO",1,0)="Encounters with No Action Taken: "_NOACT
... S NCNT=NCNT+1
... S LINE=" " F SDI=".07",".11",".05" S LINE=LINE_$G(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
... I $E(LINE,$L(LINE),$L(LINE))="-" S LINE=$E(LINE,1,$L(LINE)-1)
... S ^TMP("SDSCPRG",$J,"NO",NCNT,0)=LINE_"-Enc #: "_SDOE
... S DA=SDOE D ^DIK
.. ; Set information into ^TMP for report
.. S WCNT=WCNT+1
.. S LINE=" " F SDI=".07",".11",".05" S LINE=LINE_$G(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
.. I $E(LINE,$L(LINE),$L(LINE))="-" S LINE=$E(LINE,1,$L(LINE)-1)
.. S ^TMP("SDSCPRG",$J,"WITH",WCNT,0)=LINE_"-Enc #: "_SDOE
.. S SDJ=SDOE F S SDJ=$O(ATEXT(409.481,SDJ)) Q:SDJ="" D
... S LINE=" ",WCNT=WCNT+1
... F SDI=".03",".02",".04" S LINE=LINE_$G(ATEXT(409.481,SDJ,SDI,"E"))_"-"
... I $G(ATEXT(409.481,SDJ,".06","E"))="YES" S LINE=LINE_"REVIEW"
... I $G(ATEXT(409.481,SDJ,".05","E"))="YES" S LINE=LINE_"SC YES"
... I $G(ATEXT(409.481,SDJ,".05","E"))="NO" S LINE=LINE_"SC NO"
... S ^TMP("SDSCPRG",$J,"WITH",WCNT,0)=LINE
.. S DA=SDOE D ^DIK
I '$D(^TMP("SDSCPRG",$J)) D G END
. N DIR,X,Y
. I $E(IOST,1,2)="C-" S DIR(0)="E" W !!,"No records found to purge." D ^DIR
I $D(^TMP("SDSCPRG",$J))>0 D
. S CNT=0,SDJ=0
. F S SDJ=$O(^TMP("SDSCPRG",$J,"NO",SDJ)) Q:SDJ="" D
.. S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=^TMP("SDSCPRG",$J,"NO",SDJ,0)
. I CNT>0 S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=""
. S SDJ=0 F S SDJ=$O(^TMP("SDSCPRG",$J,"WITH",SDJ)) Q:SDJ="" D
.. S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=^TMP("SDSCPRG",$J,"WITH",SDJ,0)
. S XMZ(DUZ)="",XMDUZ="ASCD Purge Check",XMY("G.SDSC NIGHTLY TALLY")=""
. S XMTEXT="^TMP(""SDSCPMSG"",$J,",XMSUB="ASCD PURGE REPORT"
. NEW DIFROM
. D ^XMD
. K XMZ,XMTEXT,XMSUB,XMDUZ,XMY
;
END K ^TMP("DIERR",$J),^TMP("SDSCPRG",$J),^TMP("SDSCPMSG",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDSCPRG 2999 printed Dec 13, 2024@03:01:15 Page 2
SDSCPRG ;ALB/JAM/RBS - ASCD Purge encounters that have been deleted ; 1/19/07 12:39pm
+1 ;;5.3;Scheduling;**495**;Aug 13, 1993;Build 50
+2 ;;MODIFIED FOR NATIONAL RELEASE from a Class III software product
+3 ;;known as Service Connected Automated Monitoring (SCAM).
+4 ;
+5 ;**Program Description**
+6 ; This program will check to see if an encounter in the
+7 ; SD SERVICE CONNECTED CHANGES File (#409.48)
+8 ; has been deleted from the OUTPATIENT ENCOUNTER file (#409.68) and
+9 ; remove that record from file #409.48.
+10 QUIT
EN ; Entry point
+1 NEW SDOE,NOACT,ACT,NCNT,WCNT,DA,DIK,LINE,SDI,SDJ,CNT
+2 KILL ^TMP("SDSCPRG",$JOB),^TMP("SDSCPMSG",$JOB)
+3 SET DIK="^SDSC(409.48,"
SET (SDOE,NOACT,ACT)=0
SET (NCNT,WCNT)=1
+4 FOR
SET SDOE=$ORDER(^SDSC(409.48,SDOE))
if 'SDOE
QUIT
Begin DoDot:1
+5 IF $$GETOE^SDOE(SDOE)=""
Begin DoDot:2
+6 KILL ATEXT
+7 DO GETS^DIQ(409.48,SDOE,"**","E","ATEXT")
+8 ; Initialize message
+9 SET ^TMP("SDSCPRG",$JOB,"NO",1,0)="Encounters with No Action Taken: "_NOACT
+10 SET ^TMP("SDSCPRG",$JOB,"WITH",1,0)="Encounters with Actions Taken: "_ACT
+11 IF $DATA(ATEXT(409.481))>0
SET ACT=ACT+1
SET ^TMP("SDSCPRG",$JOB,"WITH",1,0)="Encounters with Actions Taken: "_ACT
+12 IF $DATA(ATEXT(409.481))'>0
Begin DoDot:3
+13 SET NOACT=NOACT+1
SET ^TMP("SDSCPRG",$JOB,"NO",1,0)="Encounters with No Action Taken: "_NOACT
+14 SET NCNT=NCNT+1
+15 SET LINE=" "
FOR SDI=".07",".11",".05"
SET LINE=LINE_$GET(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
+16 IF $EXTRACT(LINE,$LENGTH(LINE),$LENGTH(LINE))="-"
SET LINE=$EXTRACT(LINE,1,$LENGTH(LINE)-1)
+17 SET ^TMP("SDSCPRG",$JOB,"NO",NCNT,0)=LINE_"-Enc #: "_SDOE
+18 SET DA=SDOE
DO ^DIK
End DoDot:3
QUIT
+19 ; Set information into ^TMP for report
+20 SET WCNT=WCNT+1
+21 SET LINE=" "
FOR SDI=".07",".11",".05"
SET LINE=LINE_$GET(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
+22 IF $EXTRACT(LINE,$LENGTH(LINE),$LENGTH(LINE))="-"
SET LINE=$EXTRACT(LINE,1,$LENGTH(LINE)-1)
+23 SET ^TMP("SDSCPRG",$JOB,"WITH",WCNT,0)=LINE_"-Enc #: "_SDOE
+24 SET SDJ=SDOE
FOR
SET SDJ=$ORDER(ATEXT(409.481,SDJ))
if SDJ=""
QUIT
Begin DoDot:3
+25 SET LINE=" "
SET WCNT=WCNT+1
+26 FOR SDI=".03",".02",".04"
SET LINE=LINE_$GET(ATEXT(409.481,SDJ,SDI,"E"))_"-"
+27 IF $GET(ATEXT(409.481,SDJ,".06","E"))="YES"
SET LINE=LINE_"REVIEW"
+28 IF $GET(ATEXT(409.481,SDJ,".05","E"))="YES"
SET LINE=LINE_"SC YES"
+29 IF $GET(ATEXT(409.481,SDJ,".05","E"))="NO"
SET LINE=LINE_"SC NO"
+30 SET ^TMP("SDSCPRG",$JOB,"WITH",WCNT,0)=LINE
End DoDot:3
+31 SET DA=SDOE
DO ^DIK
End DoDot:2
End DoDot:1
+32 IF '$DATA(^TMP("SDSCPRG",$JOB))
Begin DoDot:1
+33 NEW DIR,X,Y
+34 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
WRITE !!,"No records found to purge."
DO ^DIR
End DoDot:1
GOTO END
+35 IF $DATA(^TMP("SDSCPRG",$JOB))>0
Begin DoDot:1
+36 SET CNT=0
SET SDJ=0
+37 FOR
SET SDJ=$ORDER(^TMP("SDSCPRG",$JOB,"NO",SDJ))
if SDJ=""
QUIT
Begin DoDot:2
+38 SET CNT=CNT+1
SET ^TMP("SDSCPMSG",$JOB,CNT,0)=^TMP("SDSCPRG",$JOB,"NO",SDJ,0)
End DoDot:2
+39 IF CNT>0
SET CNT=CNT+1
SET ^TMP("SDSCPMSG",$JOB,CNT,0)=""
+40 SET SDJ=0
FOR
SET SDJ=$ORDER(^TMP("SDSCPRG",$JOB,"WITH",SDJ))
if SDJ=""
QUIT
Begin DoDot:2
+41 SET CNT=CNT+1
SET ^TMP("SDSCPMSG",$JOB,CNT,0)=^TMP("SDSCPRG",$JOB,"WITH",SDJ,0)
End DoDot:2
+42 SET XMZ(DUZ)=""
SET XMDUZ="ASCD Purge Check"
SET XMY("G.SDSC NIGHTLY TALLY")=""
+43 SET XMTEXT="^TMP(""SDSCPMSG"",$J,"
SET XMSUB="ASCD PURGE REPORT"
+44 NEW DIFROM
+45 DO ^XMD
+46 KILL XMZ,XMTEXT,XMSUB,XMDUZ,XMY
End DoDot:1
+47 ;
END KILL ^TMP("DIERR",$JOB),^TMP("SDSCPRG",$JOB),^TMP("SDSCPMSG",$JOB)
+1 QUIT
