- BGP2POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- ;
- ;SEND OUT BGP TAXONOMIES
- ; The following line prevents the "Disable Options..." and "Move
- ; Routines..." questions from being asked during the install.
- I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
- F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
- ;I $E($$VERSION^XPDUTL("BGP"),1,3)<"11.1" D MES^XPDUTL($$CJ^XLFSTR("Version 11.1 of BGP is required. Not installed.",80)) D SORRY(2) I 1
- I '$$INSTALLD("BGP*11.1*1") D SORRY(2)
- I '$$INSTALLD("BKM*2.1*2") D SORRY(2)
- Q
- ;
- PRE ;EP
- D PRE^BGP2POS2
- Q
- POST ;EP - called from kids build
- D ^BGP21
- D ^BGP22
- ;D ^BGP23
- ;D ^BGP24
- D DRUGS^BGP2POS1
- D ADA
- Q
- INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where
- ; BGPSTAL is the name of the INSTALL. E.g "AG*6.0*11".
- ;
- NEW BGPY,DIC,X,Y
- S X=$P(BGPSTAL,"*",1)
- S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
- D IX^DIC
- I Y<1 D IMES Q 0
- S DIC=DIC_+Y_",22,",X=$P(BGPSTAL,"*",2)
- D ^DIC
- I Y<1 D IMES Q 0
- S DIC=DIC_+Y_",""PAH"",",X=$P(BGPSTAL,"*",3)
- D ^DIC
- S BGPY=Y
- D IMES
- Q $S(BGPY<1:0,1:1)
- IMES ;
- D MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
- Q
- SORRY(X) ;
- KILL DIFQ
- I X=3 S XPDQUIT=2 Q
- S XPDQUIT=X
- W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
- Q
- ADA ;
- S ATXFLG=1
- S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP DENTAL EXAM ADA CODES",BGPDA))
- I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK ;get rid of existing one
- W !,"Creating/Updating DENTAL EXAM ADA Codes Taxonomy..."
- S X="BGP DENTAL EXAM ADA CODES",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
- I Y=-1 W !!,"ERROR IN CREATING DENTAL EXAM ADA CODES TAX" Q
- S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP DENTAL EXAM 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"
- S BGPX=0
- F X="0120","0150","0145",9990 S DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D
- .S BGPX=BGPX+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)=""
- .Q
- S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
- Q
- BGP2POS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 08 Dec 2010 3:10 PM ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +2 ;
- +3 ;
- +4 ;SEND OUT BGP TAXONOMIES
- +5 ; The following line prevents the "Disable Options..." and "Move
- +6 ; Routines..." questions from being asked during the install.
- +7 IF $GET(XPDENV)=1
- SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
- +8 FOR X="XPO1","XPZ1","XPZ2","XPI1"
- SET XPDDIQ(X)=0
- +9 ;I $E($$VERSION^XPDUTL("BGP"),1,3)<"11.1" D MES^XPDUTL($$CJ^XLFSTR("Version 11.1 of BGP is required. Not installed.",80)) D SORRY(2) I 1
- +10 IF '$$INSTALLD("BGP*11.1*1")
- DO SORRY(2)
- +11 IF '$$INSTALLD("BKM*2.1*2")
- DO SORRY(2)
- +12 QUIT
- +13 ;
- PRE ;EP
- +1 DO PRE^BGP2POS2
- +2 QUIT
- POST ;EP - called from kids build
- +1 DO ^BGP21
- +2 DO ^BGP22
- +3 ;D ^BGP23
- +4 ;D ^BGP24
- +5 DO DRUGS^BGP2POS1
- +6 DO ADA
- +7 QUIT
- INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where
- +1 ; BGPSTAL is the name of the INSTALL. E.g "AG*6.0*11".
- +2 ;
- +3 NEW BGPY,DIC,X,Y
- +4 SET X=$PIECE(BGPSTAL,"*",1)
- +5 SET DIC="^DIC(9.4,"
- SET DIC(0)="FM"
- SET D="C"
- +6 DO IX^DIC
- +7 IF Y<1
- DO IMES
- QUIT 0
- +8 SET DIC=DIC_+Y_",22,"
- SET X=$PIECE(BGPSTAL,"*",2)
- +9 DO ^DIC
- +10 IF Y<1
- DO IMES
- QUIT 0
- +11 SET DIC=DIC_+Y_",""PAH"","
- SET X=$PIECE(BGPSTAL,"*",3)
- +12 DO ^DIC
- +13 SET BGPY=Y
- +14 DO IMES
- +15 QUIT $SELECT(BGPY<1:0,1:1)
- IMES ;
- +1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
- +2 QUIT
- SORRY(X) ;
- +1 KILL DIFQ
- +2 IF X=3
- SET XPDQUIT=2
- QUIT
- +3 SET XPDQUIT=X
- +4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
- +5 QUIT
- ADA ;
- +1 SET ATXFLG=1
- +2 SET BGPDA=0
- SET BGPDA=$ORDER(^ATXAX("B","BGP DENTAL EXAM ADA CODES",BGPDA))
- +3 ;get rid of existing one
- IF BGPDA
- SET DIK="^ATXAX("
- SET DA=BGPDA
- DO ^DIK
- +4 WRITE !,"Creating/Updating DENTAL EXAM ADA Codes Taxonomy..."
- +5 SET X="BGP DENTAL EXAM ADA CODES"
- SET DIC="^ATXAX("
- SET DIC(0)="L"
- SET DIADD=1
- SET DLAYGO=9002226
- DO ^DIC
- KILL DIC,DA,DIADD,DLAYGO,I
- +6 IF Y=-1
- WRITE !!,"ERROR IN CREATING DENTAL EXAM ADA CODES TAX"
- QUIT
- +7 SET BGPTX=+Y
- SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP DENTAL EXAM ADA CODES"
- SET $PIECE(^(0),U,5)=DUZ
- SET $PIECE(^(0),U,8)=0
- SET $PIECE(^(0),U,9)=DT
- SET $PIECE(^(0),U,12)=174
- SET $PIECE(^(0),U,13)=0
- SET $PIECE(^(0),U,15)=9999999.31
- SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
- +8 SET BGPX=0
- +9 FOR X="0120","0150","0145",9990
- SET DIC="^AUTTADA("
- SET DIC(0)="M"
- DO ^DIC
- KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0
- IF $PIECE(Y,U)>0
- Begin DoDot:1
- +10 SET BGPX=BGPX+1
- +11 SET ^ATXAX(BGPTX,21,BGPX,0)=+Y
- SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX
- SET $PIECE(^(0),U,4)=BGPX
- SET ^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""
- +12 QUIT
- End DoDot:1
- +13 SET DA=BGPTX
- SET DIK="^ATXAX("
- DO IX1^DIK
- +14 QUIT
