SD53P317 ;ALB/JAM - Restricting Stop Code Post-Init Rtn ; 0707/03
;;5.3;Scheduling;**317**;AUG 13, 1993
;
POST ; entry point
;* Appropriating Stop Code fl #40.7 entries with restriction type & date
N SDJ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSAVE
I $D(^UTL("STPCODE")) K ^UTL("STPCODE")
S SDJ=$J
D MES^XPDUTL(" ")
D BMES^XPDUTL("This post install process does the following:-")
D BMES^XPDUTL(" 1. Appropriates Stop Code entries in CLINIC STOP file (#40.7) with a ")
D MES^XPDUTL(" Restriction Type and Date.")
D BMES^XPDUTL(" 2. Check clinics in file #44 for nonconforming Stop Codes and produces")
D MES^XPDUTL(" a MailMan message.")
D MES^XPDUTL(" ")
;read and store stop codes in ^UTILITY("STPCODE",SDJ,
D ^SDSTPD1
;assign stop code restriction type and restriction date
D STPMOD
;check file #44 for non-conforming restriction type
S ZTRTN="PROCESS^SD53P317"
S ZTDESC="Non-Conforming Clinics Restricted Stop Code Report"
S ZTIO="",ZTDTH=$H,ZTREQ="@" D ^%ZTLOAD
D MES^XPDUTL(" ")
D BMES^XPDUTL("completed...")
D MES^XPDUTL(" ")
K ^UTILITY("STPCODE")
Q
STPMOD ;* designate stop codes in file 40.7 as primary, secondary or either
;
; SDXX is in format:
; STOP CODE^NAME^RESTRICTION TYPE^RESTRICTION DATE^INACTIVE DATE
;
N SDX,SDXX,NAME,CODE,RESTY,RESDT,X,Y,DIC,DIE,DA,DR,IEN,INACT
D BMES^XPDUTL("Adding Restricted Type and Restricted Date to CLINIC STOP File (#40.7)...")
D MES^XPDUTL(" ")
S SDX=0 F S SDX=$O(^UTILITY("STPCODE",SDJ,SDX)) Q:'SDX S SDXX=^(SDX) D
.S CODE=$P(SDXX,U),NAME=$P(SDXX,U,2),RESTY=$P(SDXX,U,3)
.S RESDT=$P(SDXX,U,4),INACT=$P(SDXX,U,5)
.I '$D(^DIC(40.7,"C",CODE)) S ^TMP("STPCD",$J,CODE)=SDXX Q
.S IEN=$O(^DIC(40.7,"C",CODE,0)) I 'IEN Q
.I '$D(^DIC(40.7,IEN,0)) S ^TMP("STPCD",$J,CODE)=SDXX Q
.S IEN=0 F S IEN=$O(^DIC(40.7,"C",CODE,IEN)) Q:'IEN D FILSC
.W !,?2,CODE,?7,NAME,?40,"National Code Updated...."
D MES^XPDUTL(" ")
S RESTY="S" F SDX=450:1:485 D
.Q:'$D(^DIC(40.7,"C",SDX)) S IEN=$O(^DIC(40.7,"C",SDX,0)) I 'IEN Q
.Q:'$D(^DIC(40.7,IEN,0)) S SDXX=^(0) S RESDT="10/1/2003"
.S IEN=0 F S IEN=$O(^DIC(40.7,"C",SDX,IEN)) Q:'IEN D FILSC
.W !,?2,SDX,?7,$P(SDXX,U),?40,"Local Code Updated...."
D MES^XPDUTL(" ")
S CODE="" F S CODE=$O(^TMP("STPCD",$J,CODE)) Q:CODE="" D
.S SDX=^TMP("STPCD",$J,CODE),NAME=$P(SDX,U,2)
.S RESTY=$P(SDXX,U,3),RESDT=$P(SDXX,U,4),INACT=$P(SDXX,U,5)
.W !,?2,CODE,?7,NAME,?40,"Problematic....code not in file 40.7"
D MES^XPDUTL(" ")
S IEN=0 F S IEN=$O(^DIC(40.7,IEN)) Q:'IEN D
.S SDXX=$G(^DIC(40.7,IEN,0)) Q:SDXX="" Q:$P(SDXX,U,6)'=""
.W !,?2,$P(SDXX,U,2),?7,$E($P(SDXX,U),1,30),?40,"Missing Restriction Type."
Q
;
FILSC ;Update stop code in file 40.7
S DIE="^DIC(40.7,"
S DA=IEN,DR="5////"_RESTY_";6///"_RESDT D ^DIE
Q
;
PROCESS ;background entry point
; Locate invalid Stop Code in file 44 & 728.44 and put in a mail message
N SDX,IEN,BLN,COUNT,TXTVAR,I,LNS,CNT,STR,SDJ,PSC,SSC,DPC,DSC,CNTX,NAM
N SCN,PSCN,SSCN,DPCN,DSCN,IDT
S COUNT=0,$P(BLN," ",60)="",$P(LNS,"-",80)=""
S SDJ=$J K ^TMP(SDJ,"SD53P309")
F I=1:1 S TXTVAR=$P($T(MSGTXT+I),";;",2) Q:TXTVAR="QUIT" D LINE(TXTVAR)
D CK44
D MAIL
K ^TMP(SDJ,"SD53P309"),TEXT,TYP
Q
;
CK44 ;Check file 44 for invalid stop codes.
N RDT,IDAT
S (CNTX,IEN)=0
D HDR
;search file #44 for invalid entries
F S IEN=$O(^SC(IEN)) Q:'IEN D
.K STR S SDX=$G(^SC(IEN,0)),PSC=$P(SDX,U,7),SSC=$P(SDX,U,18),CNT=1
.I $P(SDX,U,3)'="C" Q
.S NAM=$P(SDX,U),IDAT=$G(^SC(IEN,"I")) I IDAT'="" D
..S IDT=$P(IDAT,U),RDT=$P(IDAT,U,2) Q:IDT="" I RDT="" S NAM="*"_NAM Q
..I RDT>IDT S NAM="*"_NAM
.S (PSCN,SSCN)="" D
..I PSC="" S STR(CNT)="Missing primary code",CNT=CNT+1 Q
..S PSCN=$$SCNUM(PSC)
..I PSCN="" S STR(CNT)=PSC_" has Inv pri ptr",CNT=CNT+1 Q
..D SCCHK(PSC,"P")
.I SSC'="" D
..S SSCN=$$SCNUM(SSC)
..I SSCN="" S STR(CNT)=SSC_" has Inv 2nd ptr",CNT=CNT+1 Q
..D SCCHK(SSC,"S")
.I $O(STR(0))'="" D LINE(.STR,"P") S CNTX=CNTX+1
D LINE(" ")
S STR=$E(BLN,1,25)_$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
D LINE(STR)
D LINE(" ")
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 D CNTR Q
.S STR(CNT)=SCIEN_" Invalid pointer."
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
;
HDR ;Header for data from file #44
D LINE(" ")
S STR="HOSPITAL LOCATION FILE (#44) - (Use Set up a Clinic [SDBUILD]"
S STR=STR_" menu option to"
D LINE(STR)
S STR=$E(BLN,1,32)_"make corrections)"
D LINE(STR)
D LINE(" ")
S STR=$E(BLN,1,35)_$E("PRIMARY"_BLN,1,10)
S STR=STR_$E("SECONDARY/"_BLN,1,11)_"REASON FOR"
D LINE(STR)
S STR=$E("CLINIC NAME"_BLN,1,35)_$E("STOP"_BLN,1,10)
S STR=STR_$E("CREDIT"_BLN,1,11)_"NON"
D LINE(STR)
S STR=$E("(* - currently inactive)"_BLN,1,35)_$E("CODE"_BLN,1,10)
S STR=STR_$E("STOP CODE"_BLN,1,11)_"CONFORMANCE"
D LINE(STR)
S STR=$E(LNS,1,80)
D LINE(STR)
Q
;
MSGTXT ; Message intro
;; Please forward this message to your local MAS ADPAC.
;;
;; A review of the Primary and Secondary Stop Codes in the HOSPITAL
;; LOCATION file (#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($$SCNUM(PSC)_BLN,1,$S(TYP="P":10,1:9))
.S STR=STR_$E($$SCNUM(SSC)_BLN,1,$S(TYP="P":11,1:9))
.I TYP="S" S STR=STR_$E($$SCNUM(DPC)_BLN,1,9)_$E($$SCNUM(DSC)_BLN,1,9)
.;set line in ^tmp global
.S XI=0 F S XI=$O(TEXT(XI)) Q:'XI D
..;I XI'=FLN S TEXT(XI)=$E(BLN,1,57)_TEXT(XI)
..S TEXT(XI)=STR_TEXT(XI)
..S COUNT=COUNT+1,^TMP(SDJ,"SD53P309",COUNT)=TEXT(XI)
S COUNT=COUNT+1,^TMP(SDJ,"SD53P309",COUNT)=TEXT
Q
;
MAIL ; Send message
N XMDUZ,XMY,XMTEXT,XMSUB
S XMY(DUZ)="",XMDUZ=.5
S XMSUB="Non-Conforming Clinics Restricted Stop Codes"
S XMTEXT="^TMP(SDJ,""SD53P309"","
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53P317 6494 printed Oct 16, 2024@18:46:48 Page 2
SD53P317 ;ALB/JAM - Restricting Stop Code Post-Init Rtn ; 0707/03
+1 ;;5.3;Scheduling;**317**;AUG 13, 1993
+2 ;
POST ; entry point
+1 ;* Appropriating Stop Code fl #40.7 entries with restriction type & date
+2 NEW SDJ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSAVE
+3 IF $DATA(^UTL("STPCODE"))
KILL ^UTL("STPCODE")
+4 SET SDJ=$JOB
+5 DO MES^XPDUTL(" ")
+6 DO BMES^XPDUTL("This post install process does the following:-")
+7 DO BMES^XPDUTL(" 1. Appropriates Stop Code entries in CLINIC STOP file (#40.7) with a ")
+8 DO MES^XPDUTL(" Restriction Type and Date.")
+9 DO BMES^XPDUTL(" 2. Check clinics in file #44 for nonconforming Stop Codes and produces")
+10 DO MES^XPDUTL(" a MailMan message.")
+11 DO MES^XPDUTL(" ")
+12 ;read and store stop codes in ^UTILITY("STPCODE",SDJ,
+13 DO ^SDSTPD1
+14 ;assign stop code restriction type and restriction date
+15 DO STPMOD
+16 ;check file #44 for non-conforming restriction type
+17 SET ZTRTN="PROCESS^SD53P317"
+18 SET ZTDESC="Non-Conforming Clinics Restricted Stop Code Report"
+19 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTREQ="@"
DO ^%ZTLOAD
+20 DO MES^XPDUTL(" ")
+21 DO BMES^XPDUTL("completed...")
+22 DO MES^XPDUTL(" ")
+23 KILL ^UTILITY("STPCODE")
+24 QUIT
STPMOD ;* designate stop codes in file 40.7 as primary, secondary or either
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE^NAME^RESTRICTION TYPE^RESTRICTION DATE^INACTIVE DATE
+4 ;
+5 NEW SDX,SDXX,NAME,CODE,RESTY,RESDT,X,Y,DIC,DIE,DA,DR,IEN,INACT
+6 DO BMES^XPDUTL("Adding Restricted Type and Restricted Date to CLINIC STOP File (#40.7)...")
+7 DO MES^XPDUTL(" ")
+8 SET SDX=0
FOR
SET SDX=$ORDER(^UTILITY("STPCODE",SDJ,SDX))
if 'SDX
QUIT
SET SDXX=^(SDX)
Begin DoDot:1
+9 SET CODE=$PIECE(SDXX,U)
SET NAME=$PIECE(SDXX,U,2)
SET RESTY=$PIECE(SDXX,U,3)
+10 SET RESDT=$PIECE(SDXX,U,4)
SET INACT=$PIECE(SDXX,U,5)
+11 IF '$DATA(^DIC(40.7,"C",CODE))
SET ^TMP("STPCD",$JOB,CODE)=SDXX
QUIT
+12 SET IEN=$ORDER(^DIC(40.7,"C",CODE,0))
IF 'IEN
QUIT
+13 IF '$DATA(^DIC(40.7,IEN,0))
SET ^TMP("STPCD",$JOB,CODE)=SDXX
QUIT
+14 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(40.7,"C",CODE,IEN))
if 'IEN
QUIT
DO FILSC
+15 WRITE !,?2,CODE,?7,NAME,?40,"National Code Updated...."
End DoDot:1
+16 DO MES^XPDUTL(" ")
+17 SET RESTY="S"
FOR SDX=450:1:485
Begin DoDot:1
+18 if '$DATA(^DIC(40.7,"C",SDX))
QUIT
SET IEN=$ORDER(^DIC(40.7,"C",SDX,0))
IF 'IEN
QUIT
+19 if '$DATA(^DIC(40.7,IEN,0))
QUIT
SET SDXX=^(0)
SET RESDT="10/1/2003"
+20 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(40.7,"C",SDX,IEN))
if 'IEN
QUIT
DO FILSC
+21 WRITE !,?2,SDX,?7,$PIECE(SDXX,U),?40,"Local Code Updated...."
End DoDot:1
+22 DO MES^XPDUTL(" ")
+23 SET CODE=""
FOR
SET CODE=$ORDER(^TMP("STPCD",$JOB,CODE))
if CODE=""
QUIT
Begin DoDot:1
+24 SET SDX=^TMP("STPCD",$JOB,CODE)
SET NAME=$PIECE(SDX,U,2)
+25 SET RESTY=$PIECE(SDXX,U,3)
SET RESDT=$PIECE(SDXX,U,4)
SET INACT=$PIECE(SDXX,U,5)
+26 WRITE !,?2,CODE,?7,NAME,?40,"Problematic....code not in file 40.7"
End DoDot:1
+27 DO MES^XPDUTL(" ")
+28 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(40.7,IEN))
if 'IEN
QUIT
Begin DoDot:1
+29 SET SDXX=$GET(^DIC(40.7,IEN,0))
if SDXX=""
QUIT
if $PIECE(SDXX,U,6)'=""
QUIT
+30 WRITE !,?2,$PIECE(SDXX,U,2),?7,$EXTRACT($PIECE(SDXX,U),1,30),?40,"Missing Restriction Type."
End DoDot:1
+31 QUIT
+32 ;
FILSC ;Update stop code in file 40.7
+1 SET DIE="^DIC(40.7,"
+2 SET DA=IEN
SET DR="5////"_RESTY_";6///"_RESDT
DO ^DIE
+3 QUIT
+4 ;
PROCESS ;background entry point
+1 ; Locate invalid Stop Code in file 44 & 728.44 and put in a mail message
+2 NEW SDX,IEN,BLN,COUNT,TXTVAR,I,LNS,CNT,STR,SDJ,PSC,SSC,DPC,DSC,CNTX,NAM
+3 NEW SCN,PSCN,SSCN,DPCN,DSCN,IDT
+4 SET COUNT=0
SET $PIECE(BLN," ",60)=""
SET $PIECE(LNS,"-",80)=""
+5 SET SDJ=$JOB
KILL ^TMP(SDJ,"SD53P309")
+6 FOR I=1:1
SET TXTVAR=$PIECE($TEXT(MSGTXT+I),";;",2)
if TXTVAR="QUIT"
QUIT
DO LINE(TXTVAR)
+7 DO CK44
+8 DO MAIL
+9 KILL ^TMP(SDJ,"SD53P309"),TEXT,TYP
+10 QUIT
+11 ;
CK44 ;Check file 44 for invalid stop codes.
+1 NEW RDT,IDAT
+2 SET (CNTX,IEN)=0
+3 DO HDR
+4 ;search file #44 for invalid entries
+5 FOR
SET IEN=$ORDER(^SC(IEN))
if 'IEN
QUIT
Begin DoDot:1
+6 KILL STR
SET SDX=$GET(^SC(IEN,0))
SET PSC=$PIECE(SDX,U,7)
SET SSC=$PIECE(SDX,U,18)
SET CNT=1
+7 IF $PIECE(SDX,U,3)'="C"
QUIT
+8 SET NAM=$PIECE(SDX,U)
SET IDAT=$GET(^SC(IEN,"I"))
IF IDAT'=""
Begin DoDot:2
+9 SET IDT=$PIECE(IDAT,U)
SET RDT=$PIECE(IDAT,U,2)
if IDT=""
QUIT
IF RDT=""
SET NAM="*"_NAM
QUIT
+10 IF RDT>IDT
SET NAM="*"_NAM
End DoDot:2
+11 SET (PSCN,SSCN)=""
Begin DoDot:2
+12 IF PSC=""
SET STR(CNT)="Missing primary code"
SET CNT=CNT+1
QUIT
+13 SET PSCN=$$SCNUM(PSC)
+14 IF PSCN=""
SET STR(CNT)=PSC_" has Inv pri ptr"
SET CNT=CNT+1
QUIT
+15 DO SCCHK(PSC,"P")
End DoDot:2
+16 IF SSC'=""
Begin DoDot:2
+17 SET SSCN=$$SCNUM(SSC)
+18 IF SSCN=""
SET STR(CNT)=SSC_" has Inv 2nd ptr"
SET CNT=CNT+1
QUIT
+19 DO SCCHK(SSC,"S")
End DoDot:2
+20 IF $ORDER(STR(0))'=""
DO LINE(.STR,"P")
SET CNTX=CNTX+1
End DoDot:1
+21 DO LINE(" ")
+22 SET STR=$EXTRACT(BLN,1,25)_$SELECT(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
+23 DO LINE(STR)
+24 DO LINE(" ")
+25 QUIT
+26 ;
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 SET STR(CNT)=SCIEN_" Invalid pointer."
End DoDot:1
DO CNTR
QUIT
+6 IF RTY=""
SET STR(CNT)=SCN_" No restriction type"
DO CNTR
QUIT
+7 IF CTY'[("^"_RTY_"^")
Begin DoDot:1
+8 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 ;
HDR ;Header for data from file #44
+1 DO LINE(" ")
+2 SET STR="HOSPITAL LOCATION FILE (#44) - (Use Set up a Clinic [SDBUILD]"
+3 SET STR=STR_" menu option to"
+4 DO LINE(STR)
+5 SET STR=$EXTRACT(BLN,1,32)_"make corrections)"
+6 DO LINE(STR)
+7 DO LINE(" ")
+8 SET STR=$EXTRACT(BLN,1,35)_$EXTRACT("PRIMARY"_BLN,1,10)
+9 SET STR=STR_$EXTRACT("SECONDARY/"_BLN,1,11)_"REASON FOR"
+10 DO LINE(STR)
+11 SET STR=$EXTRACT("CLINIC NAME"_BLN,1,35)_$EXTRACT("STOP"_BLN,1,10)
+12 SET STR=STR_$EXTRACT("CREDIT"_BLN,1,11)_"NON"
+13 DO LINE(STR)
+14 SET STR=$EXTRACT("(* - currently inactive)"_BLN,1,35)_$EXTRACT("CODE"_BLN,1,10)
+15 SET STR=STR_$EXTRACT("STOP CODE"_BLN,1,11)_"CONFORMANCE"
+16 DO LINE(STR)
+17 SET STR=$EXTRACT(LNS,1,80)
+18 DO LINE(STR)
+19 QUIT
+20 ;
MSGTXT ; Message intro
+1 ;; Please forward this message to your local MAS ADPAC.
+2 ;;
+3 ;; A review of the Primary and Secondary Stop Codes in the HOSPITAL
+4 ;; LOCATION file (#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($$SCNUM(PSC)_BLN,1,$SELECT(TYP="P":10,1:9))
+6 SET STR=STR_$EXTRACT($$SCNUM(SSC)_BLN,1,$SELECT(TYP="P":11,1:9))
+7 IF TYP="S"
SET STR=STR_$EXTRACT($$SCNUM(DPC)_BLN,1,9)_$EXTRACT($$SCNUM(DSC)_BLN,1,9)
+8 ;set line in ^tmp global
+9 SET XI=0
FOR
SET XI=$ORDER(TEXT(XI))
if 'XI
QUIT
Begin DoDot:2
+10 ;I XI'=FLN S TEXT(XI)=$E(BLN,1,57)_TEXT(XI)
+11 SET TEXT(XI)=STR_TEXT(XI)
+12 SET COUNT=COUNT+1
SET ^TMP(SDJ,"SD53P309",COUNT)=TEXT(XI)
End DoDot:2
End DoDot:1
QUIT
+13 SET COUNT=COUNT+1
SET ^TMP(SDJ,"SD53P309",COUNT)=TEXT
+14 QUIT
+15 ;
MAIL ; Send message
+1 NEW XMDUZ,XMY,XMTEXT,XMSUB
+2 SET XMY(DUZ)=""
SET XMDUZ=.5
+3 SET XMSUB="Non-Conforming Clinics Restricted Stop Codes"
+4 SET XMTEXT="^TMP(SDJ,""SD53P309"","
+5 DO ^XMD
+6 QUIT
