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

BGP0POS.m

Go to the documentation of this file. 
  1. BGP0POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2008 7:41 PM ;
  1.  ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  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.  I '$$INSTALLD("BGP*9.0*1") D SORRY(2)
  1.  I $E($$VERSION^XPDUTL("BMX"),1,3)<"4.0" D MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of BMX is required.  Not installed.",80)) D SORRY(2) I 1
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires BMX v4.0....Present.",80))
  1.  Q
  1.  ;
  1. PRE ;EP
  1.  D PRE^BGP0POS2
  1.  Q
  1. POST ;EP - called from kids build
  1.  D SCHEMA
  1.  D ^BGP0TX  ;install all taxonomies
  1.  D LAB^BGP0POS1
  1.  D DRUGS^BGP0POS1
  1.  D DMADA
  1.  K ATXFLG
  1.  S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  I $E($P($G(^ATXAX(X,0)),U,1),1,3)["BGP" S $P(^ATXAX(X,0),U,4)="n"
  1.  S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  I $E($P($G(^ATXLAB(X,0)),U,1),1,3)["BGP" S $P(^ATXLAB(X,0),U,4)="n"
  1.  D SETTAX
  1.  D SETTAXL
  1.  D SETTAXF
  1.  D SEC
  1.  D EN^XBVK("ATX")
  1.  D EN^XBVK("BGP")
  1.  Q
  1. SCHEMA ;
  1.  S DA=$O(^BMXADO("B","BGP 06 HEDIS INDICATORS",0))
  1.  I 'DA D
  1.  . D ^XBFMK
  1.  . S X="BGP 06 HEDIS INDICATORS"
  1.  . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
  1.  . K DD,D0,DO
  1.  . S DIC("DR")=".02///90375.01"
  1.  . D FILE^DICN
  1.  . I Y=-1 W !!,"Creating schema failed!! " Q
  1.  . S Y=+Y
  1.  . S ^BMXADO(Y,1,0)="^90093.991^1^1"
  1.  . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
  1.  . S ^BMXADO(Y,1,"B",.05,1)=""
  1.  . S DA=Y,DIK="^BMXADO(" D IX1^DIK
  1.  . Q
  1.  S DA=$O(^BMXADO("B","BGP 07 HEDIS INDICATORS",0))
  1.  I 'DA D
  1.  . D ^XBFMK
  1.  . S X="BGP 07 HEDIS INDICATORS"
  1.  . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
  1.  . K DD,D0,DO
  1.  . S DIC("DR")=".02///90531.01"
  1.  . D FILE^DICN
  1.  . I Y=-1 W !!,"Creating schema failed!! " Q
  1.  . S Y=+Y
  1.  . S ^BMXADO(Y,1,0)="^90093.991^1^1"
  1.  . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
  1.  . S ^BMXADO(Y,1,"B",.05,1)=""
  1.  . S DA=Y,DIK="^BMXADO(" D IX1^DIK
  1.  . Q
  1.  S DA=$O(^BMXADO("B","BGP 08 HEDIS INDICATORS",0))
  1.  I 'DA D
  1.  . D ^XBFMK
  1.  . S X="BGP 08 HEDIS INDICATORS"
  1.  . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
  1.  . K DD,D0,DO
  1.  . S DIC("DR")=".02///90534.01"
  1.  . D FILE^DICN
  1.  . I Y=-1 W !!,"Creating schema failed!! " Q
  1.  . S Y=+Y
  1.  . S ^BMXADO(Y,1,0)="^90093.991^1^1"
  1.  . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
  1.  . S ^BMXADO(Y,1,"B",.05,1)=""
  1.  . S DA=Y,DIK="^BMXADO(" D IX1^DIK
  1.  . Q
  1.  S DA=$O(^BMXADO("B","BGP 09 HEDIS INDICATORS",0))
  1.  I 'DA D
  1.  . D ^XBFMK
  1.  . S X="BGP 09 HEDIS INDICATORS"
  1.  . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
  1.  . K DD,D0,DO
  1.  . S DIC("DR")=".02///90537.01"
  1.  . D FILE^DICN
  1.  . I Y=-1 W !!,"Creating schema failed!! " Q
  1.  . S Y=+Y
  1.  . S ^BMXADO(Y,1,0)="^90093.991^1^1"
  1.  . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
  1.  . S ^BMXADO(Y,1,"B",.05,1)=""
  1.  . S DA=Y,DIK="^BMXADO(" D IX1^DIK
  1.  . Q
  1.  S DA=$O(^BMXADO("B","BGP 10 HEDIS INDICATORS",0))
  1.  I 'DA D
  1.  . D ^XBFMK
  1.  . S X="BGP 10 HEDIS INDICATORS"
  1.  . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99
  1.  . K DD,D0,DO
  1.  . S DIC("DR")=".02///90378.01"
  1.  . D FILE^DICN
  1.  . I Y=-1 W !!,"Creating schema failed!! " Q
  1.  . S Y=+Y
  1.  . S ^BMXADO(Y,1,0)="^90093.991^1^1"
  1.  . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"
  1.  . S ^BMXADO(Y,1,"B",.05,1)=""
  1.  . S DA=Y,DIK="^BMXADO(" D IX1^DIK
  1.  . Q
  1.  Q
  1. DMADA ;
  1.  S ATXFLG=1
  1.  S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",BGPDA))
  1.  I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK  ;get rid of existing one
  1.  W !,"Creating/Updating Topical Fluoride ADA Codes Taxonomy..."
  1.  S X="BGP TOPICAL FLUORIDE 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 TOPICAL FLUORIDE ADA CODES TAX" Q
  1.  S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP TOPICAL FLUORIDE 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=1201,1203,1204,1205,1206,5986 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
  1.  ;
  1. SETTAXF ;
  1.  S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  D
  1.  .Q:$P(^ATXLAB(X,0),U,9)]""
  1.  .S $P(^ATXLAB(X,0),U,9)=60
  1.  .Q
  1.  Q
  1. SETTAX ;
  1.  Q:'$D(^DD(9002226,4101,0))  ;taxonomy patch not yet installed
  1.  S BGPTFI="" F  S BGPTFI=$O(^BGPTAXT("B",BGPTFI)) Q:BGPTFI=""  D
  1.  .S BGPTFIEN=$O(^BGPTAXT("B",BGPTFI,0))
  1.  .I 'BGPTFIEN Q
  1.  .Q:'$D(^BGPTAXT(BGPTFIEN))
  1.  .Q:$P(^BGPTAXT(BGPTFIEN,0),U,2)="L"
  1.  .S BGPTDA=$O(^ATXAX("B",BGPTFI,0))
  1.  .Q:'BGPTDA  ;did not find taxonomy
  1.  .S BGPE=$P(^BGPTAXT(BGPTFIEN,0),U,4)
  1.  .I BGPE=0 S $P(^ATXAX(BGPTDA,0),U,22)=1
  1.  .I BGPE=1 S $P(^ATXAX(BGPTDA,0),U,22)=0
  1.  .S $P(^ATXAX(BGPTDA,0),U,4)="n"
  1.  .;set packages in multiple
  1.  .K DIC,DA,DR
  1.  .S BGPPI=$O(^DIC(9.4,"C","BGP",0))
  1.  .Q:BGPPI=""  ;NO PACKAGE
  1.  .Q:$D(^ATXAX(BGPTDA,41,"B",BGPPI))
  1.  .S X="`"_BGPPI,DIC="^ATXAX("_BGPTDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BGPTDA
  1.  .D ^DIC
  1.  .I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXAX(BGPDA,0),U)," failed"
  1.  .K DIC,DA,Y,X
  1.  .Q
  1.  Q
  1. SETTAXL ;
  1.  Q:'$D(^DD(9002228,4101,0))  ;taxonomy patch not yet installed
  1.   S BGPTFI="" F  S BGPTFI=$O(^BGPTAXT("B",BGPTFI)) Q:BGPTFI=""  D
  1.  .S BGPTFIEN=$O(^BGPTAXT("B",BGPTFI,0))
  1.  .I 'BGPTFIEN Q
  1.  .Q:'$D(^BGPTAXT(BGPTFIEN))
  1.  .Q:$P(^BGPTAXT(BGPTFIEN,0),U,2)='"L"
  1.  .S BGPTDA=$O(^ATXLAB("B",BGPTFI,0))
  1.  .Q:'BGPTDA  ;did not find taxonomy
  1.  .S BGPE=$P(^BGPTAXT(BGPTFIEN,0),U,4)
  1.  .I BGPE=0 S $P(^ATXLAB(BGPTDA,0),U,22)=1
  1.  .I BGPE=1 S $P(^ATXLAB(BGPTDA,0),U,22)=0
  1.  .S $P(^ATXLAB(BGPTDA,0),U,4)="n"
  1.  .;set packages in multiple
  1.  .K DIC,DA,DR
  1.  .S BGPPI=$O(^DIC(9.4,"C","BGP",0))
  1.  .Q:BGPPI=""  ;NO PACKAGE
  1.  .Q:$D(^ATXLAB(BGPTDA,41,"B",BGPPI))
  1.  .S X="`"_BGPPI,DIC="^ATXLAB("_BGPTDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BGPTDA
  1.  .D ^DIC
  1.  .I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXAX(BGPDA,0),U)," failed"
  1.  .K DIC,DA,Y,X
  1.  .Q
  1.  Q
  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. CLINICS ;
  1.  ;;01
  1.  ;;06
  1.  ;;13
  1.  ;;20
  1.  ;;24
  1.  ;;28
  1.  ;;
  1. PRVS ;
  1.  ;;00
  1.  ;;11
  1.  ;;16
  1.  ;;17
  1.  ;;18
  1.  ;;21
  1.  ;;25
  1.  ;;33
  1.  ;;41
  1.  ;;44
  1.  ;;45
  1.  ;;49
  1.  ;;64
  1.  ;;68
  1.  ;;69
  1.  ;;70
  1.  ;;71
  1.  ;;72
  1.  ;;73
  1.  ;;74
  1.  ;;75
  1.  ;;76
  1.  ;;77
  1.  ;;78
  1.  ;;79
  1.  ;;80
  1.  ;;81
  1.  ;;82
  1.  ;;83
  1.  ;;84
  1.  ;;85
  1.  ;;86
  1.  ;;A1
  1.  ;;
  1. PREPROV ;;
  1.  ;;00
  1.  ;;08
  1.  ;;11
  1.  ;;16
  1.  ;;17
  1.  ;;18
  1.  ;;21
  1.  ;;24
  1.  ;;25
  1.  ;;30
  1.  ;;33
  1.  ;;41
  1.  ;;44
  1.  ;;45
  1.  ;;47
  1.  ;;49
  1.  ;;64
  1.  ;;67
  1.  ;;68
  1.  ;;70
  1.  ;;71
  1.  ;;72
  1.  ;;73
  1.  ;;74
  1.  ;;75
  1.  ;;76
  1.  ;;77
  1.  ;;78
  1.  ;;79
  1.  ;;80
  1.  ;;81
  1.  ;;82
  1.  ;;83
  1.  ;;85
  1.  ;;86
  1.  ;;A1
  1.  ;;A9
  1.  ;;B1
  1.  ;;B2
  1.  ;;B3
  1.  ;;B4
  1.  ;;B5
  1.  ;;B6
  1.  ;;
  1. SEC ;set security on selected dd's
  1. LP ;EP - loop through file entries
  1.  F I=1:1 D  Q:BGPTXT["end"
  1.  .S BGPTXT=$T(TXT+I)
  1.  .Q:BGPTXT["end"
  1.  .F J=2:1:4 S BGP(J)=$P(BGPTXT,";;",J)
  1.  .S BGP(3)=""""_BGP(3)_""""
  1.  .S BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"
  1.  .S @BGPREF=BGP(4)
  1.  Q
  1. TXT ;file entries start here
  1.  ;;90244.01;;AUDIT;;@
  1.  ;;90244.01;;DD;;@
  1.  ;;90244.01;;DEL;;@
  1.  ;;90244.01;;LAYGO;;@
  1.  ;;90244.01;;RD;;M
  1.  ;;90244.01;;WR;;@
  1.  ;;90244.02;;AUDIT;;@
  1.  ;;90244.02;;DD;;@
  1.  ;;90244.02;;DEL;;@
  1.  ;;90244.02;;LAYGO;;@
  1.  ;;90244.02;;RD;;M
  1.  ;;90244.02;;WR;;@
  1.  ;;90371.04;;AUDIT;;@
  1.  ;;90371.04;;DD;;@
  1.  ;;90371.04;;DEL;;@
  1.  ;;90371.04;;LAYGO;;M
  1.  ;;90371.04;;RD;;M
  1.  ;;90371.04;;WR;;M
  1.  ;;90372.03;;AUDIT;;@
  1.  ;;90372.03;;DD;;@
  1.  ;;90372.03;;DEL;;M
  1.  ;;90372.03;;LAYGO;;M
  1.  ;;90372.03;;RD;;M
  1.  ;;90372.03;;WR;;M
  1.  ;;90372.05;;AUDIT;;@
  1.  ;;90372.05;;DD;;@
  1.  ;;90372.05;;DEL;;M
  1.  ;;90372.05;;LAYGO;;M
  1.  ;;90372.05;;RD;;M
  1.  ;;90372.05;;WR;;M
  1.  ;;90377.12;;AUDIT;;@
  1.  ;;90377.12;;DD;;@
  1.  ;;90377.12;;DEL;;@
  1.  ;;90377.12;;LAYGO;;M
  1.  ;;90377.12;;RD;;M
  1.  ;;90377.12;;WR;;M
  1.  ;;90377.13;;AUDIT;;@
  1.  ;;90377.13;;DD;;@
  1.  ;;90377.13;;DEL;;M
  1.  ;;90377.13;;LAYGO;;M
  1.  ;;90377.13;;RD;;M
  1.  ;;90377.13;;WR;;M
  1.  ;;90377.14;;AUDIT;;@
  1.  ;;90377.14;;DD;;@
  1.  ;;90377.14;;DEL;;M
  1.  ;;90377.14;;LAYGO;;M
  1.  ;;90377.14;;RD;;M
  1.  ;;90377.14;;WR;;M
  1.  ;;end
  1.  Q