source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCRP.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1ECXSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03
2 ;;3.0;DSS EXTRACTS;**57,58**;Dec 22, 1997
3 ;
4EN ;foreground entry point
5 N ZTRTN,ZTDESC,ZTIO,ZTQUEUED,DIR,DIRUT,X,Y,ECX,ECXSD,PSC,SSC,ECXPCF
6 W @IOF
7 W "This option synchronizes the Primary and Secondary Stop Codes in the Clinics"
8 W !,"and Stop Codes File #728.44 with those in the Hospital Location File #44."
9 W !,"It produces a report highlighting any non conformance reasons that pertain"
10 W !,"to the Primary and Secondary Codes. Please contact the responsible party "
11 W !,"for corrective action."
12 S DIR(0)="SO^A:Active Clinics;I:Inactive Clinics;B:Both"
13 S DIR("A")="Select Report"
14 S DIR("?",1)="Enter an A for Active Clinics, I for Inactive Clinics,"
15 S DIR("?")="B for Both Active and Inactive Clinics"
16 D ^DIR K DIR I $D(DIRUT) G END
17 S ECXPCF=Y
18 W ". Please be patient, this may take a few moments..."
19 ;Synch primary & secondary stop codes from file #44 with #728.44
20 S ECX=0 F S ECX=$O(^ECX(728.44,ECX)) Q:'ECX D
21 .I '$D(^SC(ECX,0)) Q
22 .S ECXSD=$G(^SC(ECX,0)) I ECXSD="" Q
23 .S PSC=$S($P(ECXSD,U,7):$P($G(^DIC(40.7,$P(ECXSD,U,7),0)),U,2),1:"")
24 .S SSC=$S($P(ECXSD,U,18):$P($G(^DIC(40.7,$P(ECXSD,U,18),0)),U,2),1:"")
25 .I PSC S $P(^ECX(728.44,ECX,0),U,2)=PSC
26 .I SSC S $P(^ECX(728.44,ECX,0),U,3)=SSC
27 ;device selection
28 K IOP,%ZIS,POP,IO("Q")
29 S %ZIS("A")="Select Device: ",%ZIS="QM" D ^%ZIS I POP G END
30 I $D(IO("Q")) K IO("Q") D G END
31 .S ZTDESC="Restricted Stop Code/DSS Identifier Report",ZTSAVE("ECXPCF")=""
32 .S ZTRTN="PROCESS^ECXSCRP",ZTIO=ION D ^%ZTLOAD,HOME^%ZIS K ZTSK
33 U IO
34 D PROCESS
35END D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
36 Q
37 ;
38PROCESS ;background entry point
39 ;locate invalid Stop Code in HOSPITAL LOCATION file #44 & CLINICS
40 ;AND STOP CODES file #728.44
41 N ECX,NAM,STR,IEN,PSC,SSC,CNTX,ECXPG,ECXOUT,LNS,DPC,DSC,SCIEN,ECXF
42 N INDT,TYP,ACF,HTYP,CLNF,ECXRDT
43 S %H=$H D YX^%DTC S ECXRDT=Y
44 S $P(LNS,"-",80)="",(CNTX,IEN,ECXOUT,ECXF)=0,ECXPG=1,CLNF=0
45 ;search file #728.44 for invalid stop code entries
46 D HDR S IEN=0
47 F S IEN=$O(^ECX(728.44,IEN)) Q:'IEN D Q:ECXOUT S:ECXF CNTX=CNTX+1
48 .S ECX=$G(^ECX(728.44,IEN,0)),PSC=$P(ECX,U,2),SSC=$P(ECX,U,3),CLNF=0
49 .S DPC=$P(ECX,U,4),DSC=$P(ECX,U,5),NAM=$$GET1^DIQ(44,$P(ECX,U),.01)
50 .S INDT=$P(ECX,U,10),ECXF=0 I INDT'="" S NAM="*"_NAM
51 .S ACF=$S($E(NAM)="*":0,1:1),HTYP=$$GET1^DIQ(44,$P(ECX,U),2,"I")
52 .I $S((ECXPCF="A")&('ACF):1,(ECXPCF="I")&(ACF):1,1:0) Q
53 .D I ECXOUT Q
54 ..I PSC="" S STR="Missing primary code" D PRN Q
55 ..D SCCHK(PSC,"P") I $D(STR) D PRN
56 .I SSC'="" D SCCHK(SSC,"S") I $D(STR) D PRN
57 .D I ECXOUT Q
58 ..I DPC="" S STR="No DSS primary code" D PRN Q
59 ..I DPC'=PSC D SCCHK(DPC,"P") I $D(STR) D PRN
60 .I DSC'="",DSC'=SSC D SCCHK(DSC,"S") I $D(STR) D PRN
61 W !!,?25,$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
62 Q
63PRN ;print line
64 Q:CLNF I HTYP'="C" S STR="Not a Clinic" S CLNF=1
65 I ($Y+3)>IOSL D PAGE,HDR I ECXOUT Q
66 W !,IEN,?8,$E(NAM,1,24),?33,PSC,?38,SSC,?45,DPC,?50,DSC,?57,STR
67 S ECXF=1
68 Q
69 ;
70SCCHK(SCIEN,TYP) ;check stop code against file 40.7
71 N SCN,RTY,CTY,SCI
72 K STR
73 S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
74 S SCI=$$SCIEN(SCIEN) I SCI="" D Q
75 .I TYP="S" Q:SSC=PSC Q:DSC=DPC
76 .S STR=SCIEN_" Invalid Stop Code"
77 S SCN=$G(^DIC(40.7,SCI,0)),RTY=$P(SCN,U,6)
78 I $P(SCN,U,2)="" S STR="No pointer in file #40.7" Q
79 I RTY="" S STR=SCIEN_" No restriction type" Q
80 I CTY'[("^"_RTY_"^") D
81 .S STR=SCIEN_" cannot be "_$S(TYP="P":"prim",1:"second")_"ary"
82 Q
83PAGE ;
84 N SS,JJ,DIR,X,Y
85 I $E(IOST,1,2)="C-" D
86 . S SS=22-$Y F JJ=1:1:SS W !
87 . S DIR(0)="E" W ! D ^DIR K DIR I 'Y S ECXOUT=1
88 Q
89 ;
90SCIEN(SCIEN) ;Get stop code IEN
91 I SCIEN="" Q ""
92 S SCIEN=$O(^DIC(40.7,"C",SCIEN,0))
93 Q SCIEN
94 ;
95HDR ;header for data from file #728.44
96 W @IOF
97 W ECXRDT,?73,"Page: ",ECXPG,!
98 W !,?18,"DSS IDENTIFIER NON-CONFORMING CLINICS REPORT",!,?32
99 W $S(ECXPCF="A":"Active",ECXPCF="I":"Inactive",1:"All")_" Clinics",!
100 W !,"CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
101 W "Stop Codes for",!,?25,"Clinics' [ECXSCEDIT] menu option to "
102 W "make corrections)",!!,?45,"DSS",?50,"DSS"
103 W !,?33,"PRIM",?38,"2NDARY",?45,"PRIM",?50,"2NDARY"
104 W !,?8,$S(ECXPCF="B":"CLINIC NAME",1:""),?33,"STOP",?38,"CREDIT"
105 W ?45,"STOP",?50,"CREDIT",?57,"REASON FOR NON-",!
106 W "IEN #",?8,$S(ECXPCF="B":"(*currently inactive)",1:"CLINIC NAME")
107 W ?33,"CODE",?38,"CODE",?45,"CODE",?50,"CODE",?57,"CONFORMANCE"
108 W !,$E(LNS,1,80)
109 S ECXPG=ECXPG+1
110 Q
Note: See TracBrowser for help on using the repository browser.