Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCLD.m

    r613 r623  
    1 ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 5/24/07 3:49pm
    2         ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105**;Dec 22, 1997;Build 70
    3 EN      ;entry point from option
    4         ;load entries
    5         W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",!
    6         I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
    7         K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD
    8         Q
    9 START   ; entry point
    10         S EC=0,ECNT=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX
    11         K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
    12         ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT
    13         K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP
    14         S ZTREQ="@" Q
    15         ;
    16 FIX     ; get stop codes and default style for feeder key
    17         ; 1 if no credit stop code - 5 if credit stop code exists
    18         K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS)
    19         S ID=+DAT,RD=$P(DAT,U,2)
    20         I $D(ECD2) D
    21         .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID
    22         .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
    23         .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
    24         .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)=""
    25         F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)
    26         S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6
    27         S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18)
    28         I '$D(ECD2) D
    29         .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF
    30         I $D(ECD2) D
    31         .S $P(ECD2,U,1,3)=ECD
    32         .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)=""
    33         .S ^ECX(728.44,EC,0)=ECD2
    34         Q
    35         ;
    36 PRINT   ; print worksheet for updates
    37         I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
    38         W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval.  Clinics that were"
    39         W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",!
    40         S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")="       ""U"" to print only the Clinic Stops that have not been approved."
    41         D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y)
    42         S %ZIS="Q" D ^%ZIS Q:POP
    43         I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
    44         U IO
    45 SPRINT  ; queued entry to print work sheet
    46         S QFLG=0,$P(LN,"-",81)="",PG=0
    47         S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
    48         K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J  I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
    49         D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END
    50         F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC=""  S ECD=^(ECSC) D SHOWEM Q:QFLG
    51         I $E(IOST)="C",'QFLG D SS
    52         K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS
    53         W:$Y @IOF D ^%ZISC S ZTREQ="@"
    54         Q
    55         ;
    56 HEAD    ; header for worksheet
    57         D SS Q:QFLG
    58         S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG
    59         I ECDATE]"" W !,"(last reviewed on ",ECDATE,")"
    60         E  W !,"(NEVER REVIEWED)"
    61         W !
    62         W !!,?1,"CLINIC",?31,"STOP",?38,"CREDIT",?47,"DSS",?54,"DSS",?63,"ACTION",?71,"NAT'L"
    63         W !,?31,"CODE",?38,"STOP",?47,"STOP",?54,"CREDIT",?71,"CODE",!,?1,"(* - currently inactive)",?38,"CODE",?47,"CODE",?54,"CODE",!,LN Q
    64         ;
    65 SHOWEM  ; list clinics for worksheet
    66         I $Y+4>IOSL D HEAD Q:QFLG
    67         W !!,$E(ECSC,1,31) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("31,38,47,54,66",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
    68         S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?71,$S(ECN]"":ECN,1:"____")
    69         Q
    70 SS      ;SCROLL STOPS
    71         I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
    72         I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
    73         Q
    74         ;
    75 EDIT    ; put in DSS stopcodes and which one to send
    76         I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
    77         W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3)
    78         S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT
    79         ;
    80 APPROVE ; approve current DSS Stop and Credit Stop codes
    81         W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"".  Those entries will then be omitted"
    82         W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
    83         K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO"
    84         S DIR("?",1)="   Enter:"
    85         S DIR("?",2)="     ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
    86         S DIR("?",3)="     ""NO"" or <RET> if you do not want to approve the current information,"
    87         S DIR("?")="     ""^"" to exit option."
    88         D ^DIR K DIR I 'Y!($D(DIRUT)) G END
    89         W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END
    90         ;
    91 APPLOOP ; queued entry to approve action codes
    92         F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC  I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE
    93         S ZTREQ="@" G END
    94 END     K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN
    95         Q
    96         ;
    97 LOOK    ;queued entry to check for new clinics
    98         S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
    99         F EC=0:0 S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D
    100         .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
    101         .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_"    "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
    102         D ^ECXSCX1
    103         Q
     1ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 9/21/04 7:33am
     2 ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80**;Dec 22, 1997
     3EN ;entry point from option
     4 ;load entries
     5 W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",!
     6 I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
     7 K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD
     8 Q
     9START ; entry point
     10 S EC=0,ECNT=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX
     11 K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
     12 ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT
     13 K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP
     14 S ZTREQ="@" Q
     15 ;
     16FIX ; get stop codes and default style for feeder key
     17 ; 1 if no credit stop code - 5 if credit stop code exists
     18 K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS)
     19 S ID=+DAT,RD=$P(DAT,U,2)
     20 I $D(ECD2) D
     21 .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID
     22 .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
     23 .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
     24 .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)=""
     25 F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)
     26 S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6
     27 S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18)
     28 I '$D(ECD2) D
     29 .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF
     30 I $D(ECD2) D
     31 .S $P(ECD2,U,1,3)=ECD
     32 .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)=""
     33 .S ^ECX(728.44,EC,0)=ECD2
     34 Q
     35 ;
     36PRINT ; print worksheet for updates
     37 I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
     38 W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval.  Clinics that were"
     39 W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",!
     40 S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")="       ""U"" to print only the Clinic Stops that have not been approved."
     41 D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y)
     42 S %ZIS="Q" D ^%ZIS Q:POP
     43 I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
     44 U IO
     45SPRINT ; queued entry to print work sheet
     46 S QFLG=0,$P(LN,"-",81)="",PG=0
     47 S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
     48 K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J  I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
     49 D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END
     50 F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC=""  S ECD=^(ECSC) D SHOWEM Q:QFLG
     51 I $E(IOST)="C",'QFLG D SS
     52 K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS
     53 W:$Y @IOF D ^%ZISC S ZTREQ="@"
     54 Q
     55 ;
     56HEAD ; header for worksheet
     57 D SS Q:QFLG
     58 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG
     59 I ECDATE]"" W !,"(last reviewed on ",ECDATE,")"
     60 E  W !,"(NEVER REVIEWED)"
     61 W !
     62 W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?50,"DSS",?59,"ACTION",?67,"NAT'L",?74,"DSS"
     63 W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67,"CODE",?74,"DEPT",!,?1,"(* - currently inactive)",?34,"CODE",?43,"CODE",?50,"CODE",!,LN Q
     64 ;
     65SHOWEM ; list clinics for worksheet
     66 I $Y+4>IOSL D HEAD Q:QFLG
     67 W !!,$E(ECSC,1,25) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("27,34,43,50,62",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
     68 S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?67,$S(ECN]"":ECN,1:"____"),?74,$S($P(ECD,U,10)'="":$P(ECD,U,10),1:"___")
     69 Q
     70SS ;SCROLL STOPS
     71 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
     72 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
     73 Q
     74 ;
     75EDIT ; put in DSS stopcodes and which one to send
     76 I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
     77 W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3)
     78 S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT
     79 ;
     80APPROVE ; approve current DSS Stop and Credit Stop codes
     81 W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"".  Those entries will then be omitted"
     82 W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
     83 K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO"
     84 S DIR("?",1)="   Enter:"
     85 S DIR("?",2)="     ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
     86 S DIR("?",3)="     ""NO"" or <RET> if you do not want to approve the current information,"
     87 S DIR("?")="     ""^"" to exit option."
     88 D ^DIR K DIR I 'Y!($D(DIRUT)) G END
     89 W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END
     90 ;
     91APPLOOP ; queued entry to approve action codes
     92 F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC  I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE
     93 S ZTREQ="@" G END
     94END K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN
     95 Q
     96 ;
     97LOOK ;queued entry to check for new clinics
     98 S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
     99 F EC=0:0 S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D
     100 .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
     101 .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_"    "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
     102 D ^ECXSCX1
     103 Q
Note: See TracChangeset for help on using the changeset viewer.