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

BGP5POS.m

Go to the documentation of this file. 
  1. BGP5POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ; 04 Aug 2015  2:27 PM
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1.  ;
  1.  ;SEND OUT BGP TAXONOMIES
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  ; '$$INSTALLD("BGP*14.1*1") D SORRY(2)
  1.  I +$$VERSION^XPDUTL("BGP")<15.0 D MES^XPDUTL($$CJ^XLFSTR("Version 15.0 of the IHS CLINICAL REPORTING is required.  Not installed",80)) D SORRY(2) I 1
  1.  Q
  1.  ;
  1. PRE ;EP
  1.  ;WIPE OUT CHS AND URBAN PARAMETERS, FIELDS ARE BEING DELETED
  1.  S BGPX=0 F  S BGPX=$O(^BGPSITE(BGPX)) Q:BGPX'=+BGPX  S DIE="^BGPSITE(",DA=BGPX,DR=".06///@;.08///@" D ^DIE K DA,DR,DIE
  1.  D PRE^BGP5POS2
  1.  S DA=$O(^DIC(19,"B","BGP 02 MENU",0))
  1.  I DA S DIE="^DIC(19,",DR="4///A" D ^DIE
  1. PRE1 ;FIX TAXONOMIES
  1.  S DA=$O(^ATXAX("B","BGPMU PREGNANCY ALL ICD",0))
  1.  I DA,$P(^ATXAX(DA,0),U,15)="" S DIE="^ATXAX(",DR=".15///80" D ^DIE
  1.  S DA=$O(^ATXAX("B","BGPMU CHEMOTHERAPY CPTS",0))
  1.  I DA,$P(^ATXAX(DA,0),U,15)="" S DIE="^ATXAX(",DR=".15///81" D ^DIE
  1.  Q
  1. POST ;EP - called from kids build
  1.  ;DELETE OLD 101, LIST TEMPLATES, REMOTE PROCEDURES
  1.  ;D DELOLD
  1.  ;D ^BGP50
  1.  ;D ^BGP51
  1.  ;D ^BGP52
  1.  D ^BGP53
  1.  S BGPX=$O(^ATXAX("B","BGP HYSTERECTOMY DXS",0))
  1.  I BGPX D
  1.  .S BGPY=0 F  S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY  D
  1.  ..I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["V67.01"!($P(^ATXAX(BGPX,21,BGPY,0),U,1)["V76.47") D
  1.  ...;delete out of multiple
  1.  ...S DA(1)=BGPX,DA=BGPY,DIK="^ATXAX("_DA(1)_",21," D ^DIK K DIK,DA
  1.  S BGPX=$O(^ATXAX("B","BGP FRACTURE DXS",0))
  1.  I BGPX D
  1.  .S BGPY=0 F  S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY  D
  1.  ..I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["733.1" D
  1.  ...;delete out of multiple
  1.  ...S DA(1)=BGPX,DA=BGPY,DIK="^ATXAX("_DA(1)_",21," D ^DIK K DIK,DA
  1.  S BGPX=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
  1.  I BGPX D
  1.  .NEW BGPY,C,CNT,G
  1.  .S BGPY=0,C=0,CNT=0,G=0 F  S BGPY=$O(^ATXAX(BGPX,21,BGPY)) Q:BGPY'=+BGPY  S C=BGPY,CNT=CNT+1 I $P(^ATXAX(BGPX,21,BGPY,0),U,1)["V02.62" S G=1
  1.  .Q:G
  1.  .S C=C+1,CNT=CNT+1,^ATXAX(BGPX,21,C,0)="V02.62 ^V02.62 ^1"
  1.  .S $P(^ATXAX(BGPX,21,0),U,3)=C
  1.  .S $P(^ATXAX(BGPX,21,0),U,4)=CNT
  1.  .S DA=C,DIK="^ATXAX(" D IX^DIK
  1.  ;D ^BGP53
  1.  D DRUGS^BGP5POS1
  1.  D LAB^BGP5POS1
  1.  D BMXPO
  1.  D ADA
  1.  D NDC
  1.  ;STUFF VERSION # IN BGP DATA FILES
  1.  D S15
  1.  Q
  1. S15 ;WIPE OUT ALL 15.0 FILES SO START CLEAN WITH 15.1 FILES
  1.  S BGPX=0 F  S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX  D
  1.  .S DA=BGPX,DIK="^BGPGPDCK(" D ^DIK
  1.  S BGPX=0 F  S BGPX=$O(^BGPGPDPK(BGPX)) Q:BGPX'=+BGPX  D
  1.  .S DA=BGPX,DIK="^BGPGPDPK(" D ^DIK
  1.  S BGPX=0 F  S BGPX=$O(^BGPGPDBK(BGPX)) Q:BGPX'=+BGPX  D
  1.  .S DA=BGPX,DIK="^BGPGPDBK(" D ^DIK
  1.  Q
  1. HOLD NEW BGPD,BGPX
  1.  S BGPX=$O(^XPD(9.7,"B","IHS CLINICAL REPORTING 15.1",0))
  1.  I 'BGPX D  Q
  1.  .;SET ALL TO 15.0
  1.  .S BGPX=0 F  S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX  D
  1.  ..Q:'$D(^BGPGPDCK(BGPX,0))
  1.  ..Q:$P(^BGPGPDCK(BGPX,0),U,21)]""
  1.  ..S DA=BGPX,DIE="^BGPGPDCK(",DR=".21///15.0" D ^DIE
  1.  ..S DA=BGPX,DIE="^BGPGPDPK(",DR=".21///15.0" D ^DIE
  1.  ..S DA=BGPX,DIE="^BGPGPDBK(",DR=".21///15.0" D ^DIE
  1.  S BGPD=$P($P(^XPD(9.7,BGPX,0),U,3),".")  ;DATE FIRST INSTALLED
  1.  ;IF DATE CREATED IS BEFORE THIS DATE SET TO 15.0, OTHERWISE SET TO 15.0
  1.  S BGPX=0 F  S BGPX=$O(^BGPGPDCK(BGPX)) Q:BGPX'=+BGPX  D
  1.  .S V=""
  1.  .Q:'$D(^BGPGPDCK(BGPX,0))
  1.  .Q:$P(^BGPGPDCK(BGPX,0),U,21)]""
  1.  .I BGPD="" S V="15.0" G S151
  1.  .I $P(^BGPGPDCK(BGPX,0),U,13)<BGPD S V="15.0" G S151
  1.  .S V="15.1"
  1. S151 .S DA=BGPX,DIE="^BGPGPDCK(",DR=".21///"_V D ^DIE
  1.  .S DA=BGPX,DIE="^BGPGPDPK(",DR=".21///"_V D ^DIE
  1.  .S DA=BGPX,DIE="^BGPGPDBK(",DR=".21///"_V D ^DIE
  1.  Q
  1. NDC ;
  1.  S BGPX=0 F  S BGPX=$O(^ATXAX(BGPX)) Q:BGPX'=+BGPX  D
  1.  .Q:$P(^ATXAX(BGPX,0),U,15)]""  ;already has a file
  1.  .Q:$P(^ATXAX(BGPX,0),U,1)'["NDC"
  1.  .Q:$E($P(^ATXAX(BGPX,0),U,1),1,3)'="BGP"
  1.  .S $P(^ATXAX(BGPX,0),U,15)=50.67
  1.  .Q
  1.  Q
  1. BMXPO ;-- update the RPC file
  1.  N BGPRPC
  1.  S BGPRPC=$O(^DIC(19,"B","BGPGRPC",0))
  1.  Q:'BGPRPC
  1.  D CLEAN(BGPRPC)
  1.  D GUIEP^BMXPO(.RETVAL,BGPRPC_"|BGP")
  1.  D GUIEP^BMXPO(.RETVAL,BGPRPC_"|ATX")
  1.  Q
  1. CLEAN(APP) ;-- clean out the RPC multiple first
  1.  S DA(1)=APP
  1.  S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
  1.  N BGPDA
  1.  S BGPDA=0 F  S BGPDA=$O(^DIC(19,APP,"RPC",BGPDA)) Q:'BGPDA  D
  1.  . S DA=BGPDA
  1.  . D ^DIK
  1.  K ^DIC(19,APP,"RPC","B")
  1.  Q
  1.  ;
  1. INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where
  1.  ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW BGPY,DIC,X,Y
  1.  S X=$P(BGPSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(BGPSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(BGPSTAL,"*",3)
  1.  D ^DIC
  1.  S BGPY=Y
  1.  D IMES
  1.  Q $S(BGPY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1. ADA ;
  1.  S ATXFLG=1
  1.  S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP GEN ANESTHESIA ADA CODES",BGPDA))
  1.  I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK  ;get rid of existing one
  1.  W !,"Creating/Updating DENTAL ANESTHESIA ADA Codes Taxonomy..."
  1.  S X="BGP GEN ANESTHESIA ADA CODES",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
  1.  I Y=-1 W !!,"ERROR IN CREATING DENTAL ANESTHISIZ ADA CODES TAX" Q
  1.  S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP GEN ANESTHESIA ADA CODES",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
  1.  S BGPX=0
  1.  F X="9220" S DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D
  1.  .S BGPX=BGPX+1
  1.  .S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""
  1.  .Q
  1.  S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
  1.  ;SSC
  1.  S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP SSC ADA CODES",BGPDA))
  1.  I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK  ;get rid of existing one
  1.  W !,"Creating/Updating SSC ADA Codes Taxonomy..."
  1.  S X="BGP SSC ADA CODES",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
  1.  I Y=-1 W !!,"ERROR IN CREATING SSC ADA CODES TAX" Q
  1.  S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP SSC ADA CODES",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
  1.  S BGPX=0
  1.  F X=2930,2931 S DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D
  1.  .S BGPX=BGPX+1
  1.  .S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""
  1.  .Q
  1.  S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
  1.  Q