source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDSCPRG.m@ 731

Last change on this file since 731 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1SDSCPRG ;ALB/JAM/RBS - ASCD Purge encounters that have been deleted ; 1/19/07 12:39pm
2 ;;5.3;Scheduling;**495**;Aug 13, 1993;Build 50
3 ;;MODIFIED FOR NATIONAL RELEASE from a Class III software product
4 ;;known as Service Connected Automated Monitoring (SCAM).
5 ;
6 ;**Program Description**
7 ; This program will check to see if an encounter in the
8 ; SD SERVICE CONNECTED CHANGES File (#409.48)
9 ; has been deleted from the OUTPATIENT ENCOUNTER file (#409.68) and
10 ; remove that record from file #409.48.
11 Q
12EN ; Entry point
13 N SDOE,NOACT,ACT,NCNT,WCNT,DA,DIK,LINE,SDI,SDJ,CNT
14 K ^TMP("SDSCPRG",$J),^TMP("SDSCPMSG",$J)
15 S DIK="^SDSC(409.48,",(SDOE,NOACT,ACT)=0,(NCNT,WCNT)=1
16 F S SDOE=$O(^SDSC(409.48,SDOE)) Q:'SDOE D
17 . I $$GETOE^SDOE(SDOE)="" D
18 .. K ATEXT
19 .. D GETS^DIQ(409.48,SDOE,"**","E","ATEXT")
20 .. ; Initialize message
21 .. S ^TMP("SDSCPRG",$J,"NO",1,0)="Encounters with No Action Taken: "_NOACT
22 .. S ^TMP("SDSCPRG",$J,"WITH",1,0)="Encounters with Actions Taken: "_ACT
23 .. I $D(ATEXT(409.481))>0 S ACT=ACT+1,^TMP("SDSCPRG",$J,"WITH",1,0)="Encounters with Actions Taken: "_ACT
24 .. I $D(ATEXT(409.481))'>0 D Q
25 ... S NOACT=NOACT+1,^TMP("SDSCPRG",$J,"NO",1,0)="Encounters with No Action Taken: "_NOACT
26 ... S NCNT=NCNT+1
27 ... S LINE=" " F SDI=".07",".11",".05" S LINE=LINE_$G(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
28 ... I $E(LINE,$L(LINE),$L(LINE))="-" S LINE=$E(LINE,1,$L(LINE)-1)
29 ... S ^TMP("SDSCPRG",$J,"NO",NCNT,0)=LINE_"-Enc #: "_SDOE
30 ... S DA=SDOE D ^DIK
31 .. ; Set information into ^TMP for report
32 .. S WCNT=WCNT+1
33 .. S LINE=" " F SDI=".07",".11",".05" S LINE=LINE_$G(ATEXT(409.48,SDOE_",",SDI,"E"))_"-"
34 .. I $E(LINE,$L(LINE),$L(LINE))="-" S LINE=$E(LINE,1,$L(LINE)-1)
35 .. S ^TMP("SDSCPRG",$J,"WITH",WCNT,0)=LINE_"-Enc #: "_SDOE
36 .. S SDJ=SDOE F S SDJ=$O(ATEXT(409.481,SDJ)) Q:SDJ="" D
37 ... S LINE=" ",WCNT=WCNT+1
38 ... F SDI=".03",".02",".04" S LINE=LINE_$G(ATEXT(409.481,SDJ,SDI,"E"))_"-"
39 ... I $G(ATEXT(409.481,SDJ,".06","E"))="YES" S LINE=LINE_"REVIEW"
40 ... I $G(ATEXT(409.481,SDJ,".05","E"))="YES" S LINE=LINE_"SC YES"
41 ... I $G(ATEXT(409.481,SDJ,".05","E"))="NO" S LINE=LINE_"SC NO"
42 ... S ^TMP("SDSCPRG",$J,"WITH",WCNT,0)=LINE
43 .. S DA=SDOE D ^DIK
44 I '$D(^TMP("SDSCPRG",$J)) D G END
45 . N DIR,X,Y
46 . I $E(IOST,1,2)="C-" S DIR(0)="E" W !!,"No records found to purge." D ^DIR
47 I $D(^TMP("SDSCPRG",$J))>0 D
48 . S CNT=0,SDJ=0
49 . F S SDJ=$O(^TMP("SDSCPRG",$J,"NO",SDJ)) Q:SDJ="" D
50 .. S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=^TMP("SDSCPRG",$J,"NO",SDJ,0)
51 . I CNT>0 S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=""
52 . S SDJ=0 F S SDJ=$O(^TMP("SDSCPRG",$J,"WITH",SDJ)) Q:SDJ="" D
53 .. S CNT=CNT+1,^TMP("SDSCPMSG",$J,CNT,0)=^TMP("SDSCPRG",$J,"WITH",SDJ,0)
54 . S XMZ(DUZ)="",XMDUZ="ASCD Purge Check",XMY("G.SDSC NIGHTLY TALLY")=""
55 . S XMTEXT="^TMP(""SDSCPMSG"",$J,",XMSUB="ASCD PURGE REPORT"
56 . NEW DIFROM
57 . D ^XMD
58 . K XMZ,XMTEXT,XMSUB,XMDUZ,XMY
59 ;
60END K ^TMP("DIERR",$J),^TMP("SDSCPRG",$J),^TMP("SDSCPMSG",$J)
61 Q
Note: See TracBrowser for help on using the repository browser.