Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SD53P317

SD53P317.m

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