source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX357PT.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.8 KB
Line 
1ECX357PT ;ALB/JAM - Restricting Stop Code Post-Init Rtn; 0707/03
2 ;;3.0;DSS EXTRACTS;**57**;Dec 22,1997
3 ;
4POST ; entry point
5 ;* Check #728.44 for appropriate Stop Code type
6 N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSAVE
7 D MES^XPDUTL(" ")
8 D BMES^XPDUTL("This post install process does the following:-")
9 D BMES^XPDUTL(" 1. Checks clinics in file #728.44 for invalid Stop Codes and produces")
10 D MES^XPDUTL(" a MailMan message.")
11 D MES^XPDUTL(" ")
12 ;check file #44 and #728.44 for non-conforming restriction type
13 S ZTRTN="PROCESS^ECX357PT"
14 S ZTDESC="DSS Identifier Non-conforming Clinics Report"
15 S ZTIO="",ZTDTH=$H,ZTREQ="@" D ^%ZTLOAD
16 D MES^XPDUTL(" ")
17 D BMES^XPDUTL("completed...")
18 D MES^XPDUTL(" ")
19 Q
20 ;
21PROCESS ;background entry point
22 ; Locate invalid Stop Code in file #728.44 and put in a mail message
23 N ECX,IEN,BLN,COUNT,TXTVAR,I,LNS,CNT,STR,ECXJ,PSC,SSC,DPC,DSC,CNTX,NAM
24 N SCN,PSCN,SSCN,DPCN,DSCN,IDT,HTYP
25 S COUNT=0,$P(BLN," ",60)="",$P(LNS,"-",80)=""
26 S ECXJ=$J K ^TMP($J,"ECX353PT")
27 F I=1:1 S TXTVAR=$P($T(MSGTXT+I),";;",2) Q:TXTVAR="QUIT" D LINE(TXTVAR)
28 D CK72844
29 D MAIL
30 K ^TMP(ECXJ,"ECX353PT"),TEXT,TYP
31 Q
32 ;
33CK72844 ;Check file 728.44 for invalid stop codes.
34 S CNTX=0
35 D HDR1
36 ;search file #728.44 for invalid entries
37 S IEN=0 F S IEN=$O(^ECX(728.44,IEN)) Q:'IEN K STR D
38 .S ECX=$G(^ECX(728.44,IEN,0)),PSC=$P(ECX,U,2),SSC=$P(ECX,U,3)
39 .S DPC=$P(ECX,U,4),DSC=$P(ECX,U,5),NAM=$$GET1^DIQ(44,$P(ECX,U),.01)
40 .S IDT=$P(ECX,U,10),CNT=1,HTYP=$$GET1^DIQ(44,$P(ECX,U),2,"I")
41 .I IDT'="" S NAM="*"_NAM
42 .S (PSCN,SSCN,DPCN,DSCN)="" D
43 ..I PSC="" S STR(CNT)="Missing primary code",CNT=CNT+1 Q
44 ..S PSCN=$$SCIEN(PSC)
45 ..I PSCN="" S STR(CNT)=PSC_" Invalid Code",CNT=CNT+1 Q
46 ..D SCCHK(PSCN,"P")
47 .I SSC'="" S SSCN=$$SCIEN(SSC) D
48 ..I SSCN="" D Q
49 ...Q:PSC=SSC S STR(CNT)=SSC_" Invalid Code",CNT=CNT+1
50 ..D SCCHK(SSCN,"S")
51 .D
52 ..I DPC="" S STR(CNT)="No DSS primary code",CNT=CNT+1 Q
53 ..S DPCN=$$SCIEN(DPC) Q:DPC=PSC
54 ..I DPCN="" D Q
55 ...S STR(CNT)=DPC_" Invalid Code",CNT=CNT+1
56 ..D SCCHK(DPCN,"P")
57 .I DSC'="",DSC'=SSC S DSCN=$$SCIEN(DSC) D
58 ..I DSCN="" D Q
59 ...Q:DSC=DPC Q:DSC=SSC Q:DSC=DPC
60 ...S STR(CNT)=DSC_" Invalid Code",CNT=CNT+1
61 ..D SCCHK(DSCN,"S")
62 .I $O(STR(0))'="" D
63 ..I HTYP'="C" K STR S STR(1)="Not a Clinic"
64 ..D LINE(.STR,"S") S CNTX=CNTX+1
65 D LINE(" ")
66 S STR=$E(BLN,1,25)_$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
67 D LINE(STR)
68 Q
69 ;
70SCNUM(SCIEN) ;Get stop code Number
71 I SCIEN="" Q ""
72 S SCN=$P($G(^DIC(40.7,SCIEN,0)),U,2)
73 Q SCN
74 ;
75SCIEN(SCN) ;Get stop code IEN
76 I SCN="" Q ""
77 S SCIEN=$O(^DIC(40.7,"C",SCN,0))
78 Q SCIEN
79 ;
80SCCHK(SCIEN,TYP) ;check stop code against file 40.7
81 N SCN,RTY,CTY
82 S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
83 S SCN=$G(^DIC(40.7,SCIEN,0)),RTY=$P(SCN,U,6),SCN=$P(SCN,U,2)
84 I SCN="" D Q
85 .I TYP="S" Q:SSC=PSC Q:DSC=DPC
86 .S STR(CNT)=SCIEN_" Invalid pointer."
87 .D CNTR
88 I RTY="" S STR(CNT)=SCN_" No restriction type" D CNTR Q
89 I CTY'[("^"_RTY_"^") D
90 .S STR(CNT)=SCN_" cannot be "_$S(TYP="P":"prim",1:"second")_"ary"
91CNTR ;counter
92 S CNT=CNT+1
93 Q
94 ;
95HDR1 ;header for data from file #728.44
96 D LINE(" ")
97 D LINE(" ")
98 S STR="CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
99 S STR=STR_"Stop Codes for"
100 D LINE(STR)
101 S STR=$E(BLN,1,25)_"Clinics' [ECXSCEDIT] menu option to "
102 S STR=STR_"make corrections)"
103 D LINE(STR)
104 D LINE(" ")
105 S STR=$E(BLN,1,39)_$E("DSS"_BLN,1,9)_$E("DSS"_BLN,1,9)
106 D LINE(STR)
107 S STR=$E(BLN,1,21)_$E("PRIMARY"_BLN,1,9)_$E("2NDARY/"_BLN,1,9)
108 S STR=STR_$E("PRIMARY"_BLN,1,9)_$E("2NDARY/"_BLN,1,9)
109 D LINE(STR)
110 S STR=$E("CLINIC NAME"_BLN,1,21)_$E("STOP"_BLN,1,9)_$E("CREDIT"_BLN,1,9)
111 S STR=STR_$E("STOP"_BLN,1,9)_$E("CREDIT"_BLN,1,8)_"REASON FOR NON-"
112 D LINE(STR)
113 S STR=$E("*currently inactive"_BLN,1,21)_$E("CODE"_BLN,1,9)
114 S STR=STR_$E("CODE"_BLN,1,9)_$E("CODE"_BLN,1,9)_$E("CODE"_BLN,1,8)
115 S STR=STR_"CONFORMANCE"
116 D LINE(STR)
117 S STR=$E(LNS,1,80)
118 D LINE(STR)
119 Q
120MSGTXT ; Message intro
121 ;; Please forward this message to your local DSS Site Manager/ADPAC.
122 ;;
123 ;; A review of the Primary and Secondary Stop Codes in the CLINICS AND
124 ;; STOP CODES file (#728.44) was completed against the Restriction Type
125 ;; field (#5) of the CLINIC STOP file (#40.7) for nonconforming clinics.
126 ;;
127 ;;
128 ;;QUIT
129 ;
130 ;
131LINE(TEXT,TYP) ; Add line to message global
132 N FLN,STR,XI
133 ;build 1st line with name, codes, etc.
134 I $O(TEXT(0))'="" D Q
135 .S STR=$E(NAM_BLN,1,$S(TYP="P":35,1:21))
136 .S STR=STR_$E(PSC_BLN,1,$S(TYP="P":10,1:9))
137 .S STR=STR_$E(SSC_BLN,1,$S(TYP="P":12,1:9))
138 .I TYP="S" S STR=STR_$E(DPC_BLN,1,9)_$E(DSC_BLN,1,8)
139 .;set line in ^tmp global
140 .S XI=0 F S XI=$O(TEXT(XI)) Q:'XI D
141 ..S TEXT(XI)=STR_TEXT(XI)
142 ..S COUNT=COUNT+1,^TMP(ECXJ,"ECX353PT",COUNT)=TEXT(XI)
143 S COUNT=COUNT+1,^TMP(ECXJ,"ECX353PT",COUNT)=TEXT
144 Q
145 ;
146MAIL ; Send message
147 N XMDUZ,XMY,XMTEXT,XMSUB
148 S XMY(DUZ)="",XMDUZ=.5
149 S XMSUB="DSS Identifier Non-Conforming Clinics"
150 S XMTEXT="^TMP(ECXJ,""ECX353PT"","
151 D ^XMD
152 Q
Note: See TracBrowser for help on using the repository browser.