ECX357PT ;ALB/JAM - Restricting Stop Code Post-Init Rtn; 0707/03
;;3.0;DSS EXTRACTS;**57**;Dec 22,1997
;
POST ; entry point
;* Check #728.44 for appropriate Stop Code type
N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSAVE
D MES^XPDUTL(" ")
D BMES^XPDUTL("This post install process does the following:-")
D BMES^XPDUTL(" 1. Checks clinics in file #728.44 for invalid Stop Codes and produces")
D MES^XPDUTL(" a MailMan message.")
D MES^XPDUTL(" ")
;check file #44 and #728.44 for non-conforming restriction type
S ZTRTN="PROCESS^ECX357PT"
S ZTDESC="DSS Identifier Non-conforming Clinics Report"
S ZTIO="",ZTDTH=$H,ZTREQ="@" D ^%ZTLOAD
D MES^XPDUTL(" ")
D BMES^XPDUTL("completed...")
D MES^XPDUTL(" ")
Q
;
PROCESS ;background entry point
; Locate invalid Stop Code in file #728.44 and put in a mail message
N ECX,IEN,BLN,COUNT,TXTVAR,I,LNS,CNT,STR,ECXJ,PSC,SSC,DPC,DSC,CNTX,NAM
N SCN,PSCN,SSCN,DPCN,DSCN,IDT,HTYP
S COUNT=0,$P(BLN," ",60)="",$P(LNS,"-",80)=""
S ECXJ=$J K ^TMP($J,"ECX353PT")
F I=1:1 S TXTVAR=$P($T(MSGTXT+I),";;",2) Q:TXTVAR="QUIT" D LINE(TXTVAR)
D CK72844
D MAIL
K ^TMP(ECXJ,"ECX353PT"),TEXT,TYP
Q
;
CK72844 ;Check file 728.44 for invalid stop codes.
S CNTX=0
D HDR1
;search file #728.44 for invalid entries
S IEN=0 F S IEN=$O(^ECX(728.44,IEN)) Q:'IEN K STR D
.S ECX=$G(^ECX(728.44,IEN,0)),PSC=$P(ECX,U,2),SSC=$P(ECX,U,3)
.S DPC=$P(ECX,U,4),DSC=$P(ECX,U,5),NAM=$$GET1^DIQ(44,$P(ECX,U),.01)
.S IDT=$P(ECX,U,10),CNT=1,HTYP=$$GET1^DIQ(44,$P(ECX,U),2,"I")
.I IDT'="" S NAM="*"_NAM
.S (PSCN,SSCN,DPCN,DSCN)="" D
..I PSC="" S STR(CNT)="Missing primary code",CNT=CNT+1 Q
..S PSCN=$$SCIEN(PSC)
..I PSCN="" S STR(CNT)=PSC_" Invalid Code",CNT=CNT+1 Q
..D SCCHK(PSCN,"P")
.I SSC'="" S SSCN=$$SCIEN(SSC) D
..I SSCN="" D Q
...Q:PSC=SSC S STR(CNT)=SSC_" Invalid Code",CNT=CNT+1
..D SCCHK(SSCN,"S")
.D
..I DPC="" S STR(CNT)="No DSS primary code",CNT=CNT+1 Q
..S DPCN=$$SCIEN(DPC) Q:DPC=PSC
..I DPCN="" D Q
...S STR(CNT)=DPC_" Invalid Code",CNT=CNT+1
..D SCCHK(DPCN,"P")
.I DSC'="",DSC'=SSC S DSCN=$$SCIEN(DSC) D
..I DSCN="" D Q
...Q:DSC=DPC Q:DSC=SSC Q:DSC=DPC
...S STR(CNT)=DSC_" Invalid Code",CNT=CNT+1
..D SCCHK(DSCN,"S")
.I $O(STR(0))'="" D
..I HTYP'="C" K STR S STR(1)="Not a Clinic"
..D LINE(.STR,"S") S CNTX=CNTX+1
D LINE(" ")
S STR=$E(BLN,1,25)_$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
D LINE(STR)
Q
;
SCNUM(SCIEN) ;Get stop code Number
I SCIEN="" Q ""
S SCN=$P($G(^DIC(40.7,SCIEN,0)),U,2)
Q SCN
;
SCIEN(SCN) ;Get stop code IEN
I SCN="" Q ""
S SCIEN=$O(^DIC(40.7,"C",SCN,0))
Q SCIEN
;
SCCHK(SCIEN,TYP) ;check stop code against file 40.7
N SCN,RTY,CTY
S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
S SCN=$G(^DIC(40.7,SCIEN,0)),RTY=$P(SCN,U,6),SCN=$P(SCN,U,2)
I SCN="" D Q
.I TYP="S" Q:SSC=PSC Q:DSC=DPC
.S STR(CNT)=SCIEN_" Invalid pointer."
.D CNTR
I RTY="" S STR(CNT)=SCN_" No restriction type" D CNTR Q
I CTY'[("^"_RTY_"^") D
.S STR(CNT)=SCN_" cannot be "_$S(TYP="P":"prim",1:"second")_"ary"
CNTR ;counter
S CNT=CNT+1
Q
;
HDR1 ;header for data from file #728.44
D LINE(" ")
D LINE(" ")
S STR="CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
S STR=STR_"Stop Codes for"
D LINE(STR)
S STR=$E(BLN,1,25)_"Clinics' [ECXSCEDIT] menu option to "
S STR=STR_"make corrections)"
D LINE(STR)
D LINE(" ")
S STR=$E(BLN,1,39)_$E("DSS"_BLN,1,9)_$E("DSS"_BLN,1,9)
D LINE(STR)
S STR=$E(BLN,1,21)_$E("PRIMARY"_BLN,1,9)_$E("2NDARY/"_BLN,1,9)
S STR=STR_$E("PRIMARY"_BLN,1,9)_$E("2NDARY/"_BLN,1,9)
D LINE(STR)
S STR=$E("CLINIC NAME"_BLN,1,21)_$E("STOP"_BLN,1,9)_$E("CREDIT"_BLN,1,9)
S STR=STR_$E("STOP"_BLN,1,9)_$E("CREDIT"_BLN,1,8)_"REASON FOR NON-"
D LINE(STR)
S STR=$E("*currently inactive"_BLN,1,21)_$E("CODE"_BLN,1,9)
S STR=STR_$E("CODE"_BLN,1,9)_$E("CODE"_BLN,1,9)_$E("CODE"_BLN,1,8)
S STR=STR_"CONFORMANCE"
D LINE(STR)
S STR=$E(LNS,1,80)
D LINE(STR)
Q
MSGTXT ; Message intro
;; Please forward this message to your local DSS Site Manager/ADPAC.
;;
;; A review of the Primary and Secondary Stop Codes in the CLINICS AND
;; STOP CODES file (#728.44) was completed against the Restriction Type
;; field (#5) of the CLINIC STOP file (#40.7) for nonconforming clinics.
;;
;;
;;QUIT
;
;
LINE(TEXT,TYP) ; Add line to message global
N FLN,STR,XI
;build 1st line with name, codes, etc.
I $O(TEXT(0))'="" D Q
.S STR=$E(NAM_BLN,1,$S(TYP="P":35,1:21))
.S STR=STR_$E(PSC_BLN,1,$S(TYP="P":10,1:9))
.S STR=STR_$E(SSC_BLN,1,$S(TYP="P":12,1:9))
.I TYP="S" S STR=STR_$E(DPC_BLN,1,9)_$E(DSC_BLN,1,8)
.;set line in ^tmp global
.S XI=0 F S XI=$O(TEXT(XI)) Q:'XI D
..S TEXT(XI)=STR_TEXT(XI)
..S COUNT=COUNT+1,^TMP(ECXJ,"ECX353PT",COUNT)=TEXT(XI)
S COUNT=COUNT+1,^TMP(ECXJ,"ECX353PT",COUNT)=TEXT
Q
;
MAIL ; Send message
N XMDUZ,XMY,XMTEXT,XMSUB
S XMY(DUZ)="",XMDUZ=.5
S XMSUB="DSS Identifier Non-Conforming Clinics"
S XMTEXT="^TMP(ECXJ,""ECX353PT"","
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX357PT 5045 printed Sep 23, 2025@19:26:06 Page 2
ECX357PT ;ALB/JAM - Restricting Stop Code Post-Init Rtn; 0707/03
+1 ;;3.0;DSS EXTRACTS;**57**;Dec 22,1997
+2 ;
POST ; entry point
+1 ;* Check #728.44 for appropriate Stop Code type
+2 NEW ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSAVE
+3 DO MES^XPDUTL(" ")
+4 DO BMES^XPDUTL("This post install process does the following:-")
+5 DO BMES^XPDUTL(" 1. Checks clinics in file #728.44 for invalid Stop Codes and produces")
+6 DO MES^XPDUTL(" a MailMan message.")
+7 DO MES^XPDUTL(" ")
+8 ;check file #44 and #728.44 for non-conforming restriction type
+9 SET ZTRTN="PROCESS^ECX357PT"
+10 SET ZTDESC="DSS Identifier Non-conforming Clinics Report"
+11 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTREQ="@"
DO ^%ZTLOAD
+12 DO MES^XPDUTL(" ")
+13 DO BMES^XPDUTL("completed...")
+14 DO MES^XPDUTL(" ")
+15 QUIT
+16 ;
PROCESS ;background entry point
+1 ; Locate invalid Stop Code in file #728.44 and put in a mail message
+2 NEW ECX,IEN,BLN,COUNT,TXTVAR,I,LNS,CNT,STR,ECXJ,PSC,SSC,DPC,DSC,CNTX,NAM
+3 NEW SCN,PSCN,SSCN,DPCN,DSCN,IDT,HTYP
+4 SET COUNT=0
SET $PIECE(BLN," ",60)=""
SET $PIECE(LNS,"-",80)=""
+5 SET ECXJ=$JOB
KILL ^TMP($JOB,"ECX353PT")
+6 FOR I=1:1
SET TXTVAR=$PIECE($TEXT(MSGTXT+I),";;",2)
if TXTVAR="QUIT"
QUIT
DO LINE(TXTVAR)
+7 DO CK72844
+8 DO MAIL
+9 KILL ^TMP(ECXJ,"ECX353PT"),TEXT,TYP
+10 QUIT
+11 ;
CK72844 ;Check file 728.44 for invalid stop codes.
+1 SET CNTX=0
+2 DO HDR1
+3 ;search file #728.44 for invalid entries
+4 SET IEN=0
FOR
SET IEN=$ORDER(^ECX(728.44,IEN))
if 'IEN
QUIT
KILL STR
Begin DoDot:1
+5 SET ECX=$GET(^ECX(728.44,IEN,0))
SET PSC=$PIECE(ECX,U,2)
SET SSC=$PIECE(ECX,U,3)
+6 SET DPC=$PIECE(ECX,U,4)
SET DSC=$PIECE(ECX,U,5)
SET NAM=$$GET1^DIQ(44,$PIECE(ECX,U),.01)
+7 SET IDT=$PIECE(ECX,U,10)
SET CNT=1
SET HTYP=$$GET1^DIQ(44,$PIECE(ECX,U),2,"I")
+8 IF IDT'=""
SET NAM="*"_NAM
+9 SET (PSCN,SSCN,DPCN,DSCN)=""
Begin DoDot:2
+10 IF PSC=""
SET STR(CNT)="Missing primary code"
SET CNT=CNT+1
QUIT
+11 SET PSCN=$$SCIEN(PSC)
+12 IF PSCN=""
SET STR(CNT)=PSC_" Invalid Code"
SET CNT=CNT+1
QUIT
+13 DO SCCHK(PSCN,"P")
End DoDot:2
+14 IF SSC'=""
SET SSCN=$$SCIEN(SSC)
Begin DoDot:2
+15 IF SSCN=""
Begin DoDot:3
+16 if PSC=SSC
QUIT
SET STR(CNT)=SSC_" Invalid Code"
SET CNT=CNT+1
End DoDot:3
QUIT
+17 DO SCCHK(SSCN,"S")
End DoDot:2
+18 Begin DoDot:2
+19 IF DPC=""
SET STR(CNT)="No DSS primary code"
SET CNT=CNT+1
QUIT
+20 SET DPCN=$$SCIEN(DPC)
if DPC=PSC
QUIT
+21 IF DPCN=""
Begin DoDot:3
+22 SET STR(CNT)=DPC_" Invalid Code"
SET CNT=CNT+1
End DoDot:3
QUIT
+23 DO SCCHK(DPCN,"P")
End DoDot:2
+24 IF DSC'=""
IF DSC'=SSC
SET DSCN=$$SCIEN(DSC)
Begin DoDot:2
+25 IF DSCN=""
Begin DoDot:3
+26 if DSC=DPC
QUIT
if DSC=SSC
QUIT
if DSC=DPC
QUIT
+27 SET STR(CNT)=DSC_" Invalid Code"
SET CNT=CNT+1
End DoDot:3
QUIT
+28 DO SCCHK(DSCN,"S")
End DoDot:2
+29 IF $ORDER(STR(0))'=""
Begin DoDot:2
+30 IF HTYP'="C"
KILL STR
SET STR(1)="Not a Clinic"
+31 DO LINE(.STR,"S")
SET CNTX=CNTX+1
End DoDot:2
End DoDot:1
+32 DO LINE(" ")
+33 SET STR=$EXTRACT(BLN,1,25)_$SELECT(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
+34 DO LINE(STR)
+35 QUIT
+36 ;
SCNUM(SCIEN) ;Get stop code Number
+1 IF SCIEN=""
QUIT ""
+2 SET SCN=$PIECE($GET(^DIC(40.7,SCIEN,0)),U,2)
+3 QUIT SCN
+4 ;
SCIEN(SCN) ;Get stop code IEN
+1 IF SCN=""
QUIT ""
+2 SET SCIEN=$ORDER(^DIC(40.7,"C",SCN,0))
+3 QUIT SCIEN
+4 ;
SCCHK(SCIEN,TYP) ;check stop code against file 40.7
+1 NEW SCN,RTY,CTY
+2 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
+3 SET SCN=$GET(^DIC(40.7,SCIEN,0))
SET RTY=$PIECE(SCN,U,6)
SET SCN=$PIECE(SCN,U,2)
+4 IF SCN=""
Begin DoDot:1
+5 IF TYP="S"
if SSC=PSC
QUIT
if DSC=DPC
QUIT
+6 SET STR(CNT)=SCIEN_" Invalid pointer."
+7 DO CNTR
End DoDot:1
QUIT
+8 IF RTY=""
SET STR(CNT)=SCN_" No restriction type"
DO CNTR
QUIT
+9 IF CTY'[("^"_RTY_"^")
Begin DoDot:1
+10 SET STR(CNT)=SCN_" cannot be "_$SELECT(TYP="P":"prim",1:"second")_"ary"
End DoDot:1
CNTR ;counter
+1 SET CNT=CNT+1
+2 QUIT
+3 ;
HDR1 ;header for data from file #728.44
+1 DO LINE(" ")
+2 DO LINE(" ")
+3 SET STR="CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
+4 SET STR=STR_"Stop Codes for"
+5 DO LINE(STR)
+6 SET STR=$EXTRACT(BLN,1,25)_"Clinics' [ECXSCEDIT] menu option to "
+7 SET STR=STR_"make corrections)"
+8 DO LINE(STR)
+9 DO LINE(" ")
+10 SET STR=$EXTRACT(BLN,1,39)_$EXTRACT("DSS"_BLN,1,9)_$EXTRACT("DSS"_BLN,1,9)
+11 DO LINE(STR)
+12 SET STR=$EXTRACT(BLN,1,21)_$EXTRACT("PRIMARY"_BLN,1,9)_$EXTRACT("2NDARY/"_BLN,1,9)
+13 SET STR=STR_$EXTRACT("PRIMARY"_BLN,1,9)_$EXTRACT("2NDARY/"_BLN,1,9)
+14 DO LINE(STR)
+15 SET STR=$EXTRACT("CLINIC NAME"_BLN,1,21)_$EXTRACT("STOP"_BLN,1,9)_$EXTRACT("CREDIT"_BLN,1,9)
+16 SET STR=STR_$EXTRACT("STOP"_BLN,1,9)_$EXTRACT("CREDIT"_BLN,1,8)_"REASON FOR NON-"
+17 DO LINE(STR)
+18 SET STR=$EXTRACT("*currently inactive"_BLN,1,21)_$EXTRACT("CODE"_BLN,1,9)
+19 SET STR=STR_$EXTRACT("CODE"_BLN,1,9)_$EXTRACT("CODE"_BLN,1,9)_$EXTRACT("CODE"_BLN,1,8)
+20 SET STR=STR_"CONFORMANCE"
+21 DO LINE(STR)
+22 SET STR=$EXTRACT(LNS,1,80)
+23 DO LINE(STR)
+24 QUIT
MSGTXT ; Message intro
+1 ;; Please forward this message to your local DSS Site Manager/ADPAC.
+2 ;;
+3 ;; A review of the Primary and Secondary Stop Codes in the CLINICS AND
+4 ;; STOP CODES file (#728.44) was completed against the Restriction Type
+5 ;; field (#5) of the CLINIC STOP file (#40.7) for nonconforming clinics.
+6 ;;
+7 ;;
+8 ;;QUIT
+9 ;
+10 ;
LINE(TEXT,TYP) ; Add line to message global
+1 NEW FLN,STR,XI
+2 ;build 1st line with name, codes, etc.
+3 IF $ORDER(TEXT(0))'=""
Begin DoDot:1
+4 SET STR=$EXTRACT(NAM_BLN,1,$SELECT(TYP="P":35,1:21))
+5 SET STR=STR_$EXTRACT(PSC_BLN,1,$SELECT(TYP="P":10,1:9))
+6 SET STR=STR_$EXTRACT(SSC_BLN,1,$SELECT(TYP="P":12,1:9))
+7 IF TYP="S"
SET STR=STR_$EXTRACT(DPC_BLN,1,9)_$EXTRACT(DSC_BLN,1,8)
+8 ;set line in ^tmp global
+9 SET XI=0
FOR
SET XI=$ORDER(TEXT(XI))
if 'XI
QUIT
Begin DoDot:2
+10 SET TEXT(XI)=STR_TEXT(XI)
+11 SET COUNT=COUNT+1
SET ^TMP(ECXJ,"ECX353PT",COUNT)=TEXT(XI)
End DoDot:2
End DoDot:1
QUIT
+12 SET COUNT=COUNT+1
SET ^TMP(ECXJ,"ECX353PT",COUNT)=TEXT
+13 QUIT
+14 ;
MAIL ; Send message
+1 NEW XMDUZ,XMY,XMTEXT,XMSUB
+2 SET XMY(DUZ)=""
SET XMDUZ=.5
+3 SET XMSUB="DSS Identifier Non-Conforming Clinics"
+4 SET XMTEXT="^TMP(ECXJ,""ECX353PT"","
+5 DO ^XMD
+6 QUIT
