BDMPOST ; cmi/anch/maw - POST INIT ROUTINE ; [ 08/23/2006 3:21 PM ]
;;2.0;DIABETES MANAGEMENT SYSTEM;**1**;AUG 11, 2006
;
ENV ;EP;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
F X="XPM1","XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
;I '$$INSTALLD("ACM*2.0*6") D SORRY(2)
Q
EN D REGISTER
Q
REGISTER ;CREATE QMAN REGISTER ENTRY
Q:$D(^AMQQ(7,"B","REGISTER",52))&$D(^AMQQ(5,6,"B","CMS REGISTER"))&$D(^AMQQ(5,6,"B","REGISTER"))
N J
S Z="RTEXT"
F J=1:1 S X=$T(@Z+J) Q:X["END" D
.S X=$P(X,";;",2)
.S J=J+1
.S Y=$T(RTEXT+J)
.S Y=$P(Y,";;",2)
.S @X=Y
Q
ACM421 ;EP;TO CHECK RG MULTIPLE NODE OF THE CMS COMPLICATIONS LIST FILE
;AND ADD 2000 DIABETES AUDIT TO 'BDMMENU'
N X,Y,Z
S X=0
F S X=$O(^ACM(42.1,X)) Q:'X D
.I $D(^ACM(42.1,X,"RG",0)) S $P(^ACM(42.1,X,"RG",0),U)="",$P(^(0),U,2)="9002241.11P"
S DA(1)=$O(^DIC(19,"B","BDMMENU",0))
S X=$O(^DIC(19,"B","APCL M MAIN DM MENU",0))
Q:'DA(1)!'X
D:'$D(^DIC(19,DA(1),10,"B",X))
.K DD,DO
.S DIC="^DIC(19,DA(1),10,"
.S DIC(0)="L"
.S DIC("DR")="2////DA"
.D FILE^DICN
S DA=$O(^DIC(19,"B","BDM DIABETES AUDIT",0))
Q:'DA
S DA=$O(^DIC(19,DA(1),10,"B",DA,0))
Q:'DA
S DIK="^DIC(19,"_DA(1)_",10,"
D ^DIK
K DA,DIK,DIC,DR
Q
P2 ;EP;
I $G(^DIC(2160032,0))["DMS LETTERS" K ^DIC(2160032),^DD(2160032)
D NEWOP
D PP
D COMP
D DMLAB
P3 ;EP;
P4 ;EP;
D NEWOP
P5 ;EP;
D NEWOP
D ^BDMBUL
Q
;
P6 ;EP;
F BDMX="BDM SELF MONITORING REPORT" D
.S BDMY="SMR"
.S X=$$ADD^XPDMENU("BDM REPORTS",BDMX,BDMY)
;
;
;NEW TAXONOMY MENU OPTION
;F BDMX="BDM TAXONOMY SETUP" D
;.S BDMY="TMS"
;.S X=$$ADD^XPDMENU("BDM REGISTER MAINTENANCE",BDMX,BDMY)
;
F BDMX="APCL DM2005 DM AUDIT TAX CHECK" D
.S BDMY="D5TC"
.S X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
;
F BDMX="APCL DM2005 AUDIT TAX UPDATE" D
.S BDMY="D5TU"
.S X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
;
F BDMX="APCL DM2005 PREDIAB TAX CHECK" D
.S BDMY="PDTC"
.S X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
;
F BDMX="APCL DM2005 PREDIAB TAX UPDATE" D
.S BDMY="PDTU"
.S X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
;
;
;S BDMNAME="BDM TAXONOMY SETUP"
;S BDMOPT=$O(^DIC(19,"B",BDMNAME,0)) Q:'BDMOPT
;S DIE="^DIC(19,",DA=BDMOPT,DR="15////@;20////@"
;D ^DIE K DIE,DR,DA
;
;D ^BDMBUL6
;
NEWOPT2 ;MODIFY MAIN MENU EXIT ACTION
;
S BDMNAME="BDMMENU"
S BDMOPT=$O(^DIC(19,"B",BDMNAME,0)) Q:'BDMOPT
S DIE="^DIC(19,",DA=BDMOPT,DR="15////"_"D ^BDMKILL"
D ^DIE K DIE,DR,DA
Q
;
NEWOP ;ADD NEW OPTIONS
F BDMX="BDM EDIT PCP" D
.S BDMY="PCP"
.S X=$$ADD^XPDMENU("BDM REGISTER MAINTENANCE",BDMX,BDMY)
Q
DMLAB ;EP;TO UPDATE PRIMARY PROVIDER AND DM LAB VALUES
S BDMX="DMS DIABETES LAB REPORT"
I $D(^APCHSCTL("B",BDMX)) S BDMDA=$O(^APCHSCTL("B",BDMX,0))
Q:'$G(BDMDA)
D DMLAB^BDMFUTIL
Q
PP ;EP;TO SYNCHRONIZE PRIMARY PROVIDER WITH FILE 9000001
Q:$G(^DD(9000001,.14,0))'[200
S BDMDA=0
F S BDMDA=$O(^ACM(41,BDMDA)) Q:'BDMDA D
.W "."
.S PAT=$P(^ACM(41,BDMDA,0),U,2)
.Q:'PAT
.S PP=$P($G(^ACM(41,BDMDA,"DT")),U,15)
.Q:'PP
.S PPP=$P($G(^AUPNPAT(PAT,0)),U,14)
.Q:'PPP
.Q:PP=PPP
.W "."
.S DA=BDMDA
.S DIE="^ACM(41,"
.S DR="15////"_PPP
.D DIE^BDMFDIC
Q
COMP ;EP;TO ELIMINATE DUPLICATE COMPLICATIONS
F BDMX="CVA (STROKE)","END STAGE RENAL DISEASE","FIXED PROTEINURIA","HIGH RISK FOOT","HYPERTENSION","LASER TX FOR RETINOPATHY","MAJOR AMPUTATION(S)","MINOR AMPUTATION(S)","RETINOPATHY" D
.S (BDMY,BDMZ)=$O(^ACM(42.1,"B",BDMX,0))
.Q:'BDMY
.F S BDMZ=$O(^ACM(42.1,"B",BDMX,BDMZ)) Q:'BDMZ D
..S BDMDA=0
..F S BDMDA=$O(^ACM(42,"B",BDMZ,BDMDA)) Q:'BDMDA D
...S DA=BDMDA
...S DIE="^ACM(42,"
...S DR=".01///"_BDMY
...W "."
...D DIE^BDMFDIC
..S DA=BDMZ
..S DIK="^ACM(42.1,"
..W "."
..D DIK^BDMFDIC
Q
RTEXT ;;
;;^AMQQ(5,6,0)
;;REGISTER^^^52^40^^^^P
;;^AMQQ(5,6,1,0)
;;^9009075.01^2^2
;;^AMQQ(5,6,1,1,0)
;;REGISTER
;;^AMQQ(5,6,1,2,0)
;;CMS REGISTER
;;^AMQQ(5,6,1,"B","CMS REGISTER",2)
;;
;;^AMQQ(5,6,1,"B","REGISTER",1)
;;
;;^AMQQ(5,"C","CMS REGISTER",6,2)
;;
;;^AMQQ(5,"C","REGISTER",6,1)
;;
;;^AMQQ(7,52,0)
;;REGISTER
;;^AMQQ(7,"B","REGISTER",52)
;;
;;END
;
INSTALLD(BDMSTAL) ;EP - Determine if patch BDMSTAL was installed, where
; BDMSTAL is the name of the INSTALL. E.g "AG*6.0*11".
NEW BDMY,DIC,X,Y
S X=$P(BDMSTAL,"*",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(BDMSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BDMSTAL,"*",3)
D ^DIC
S BDMY=Y
D IMES
Q $S(BDMY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BDMSTAL_""" 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
V2POST ;EP - called from post init of kids build
NEW X
S X=$O(^ACM(58.1,"B","Case Comments",0))
I X S DA=X,DIE="^ACM(58.1,",DR=".11///@" D ^DIE K DIE,DA,DR
S X=$O(^ACM(58.1,"B","Care Plan Comment",0))
I X S DA=X,DIE="^ACM(58.1,",DR=".11///CP" D ^DIE K DIE,DA,DR
S X=$O(^ACM(58.1,"B","Complication Comments",0))
I X S DA=X,DIE="^ACM(58.1,",DR=".11///CMP" D ^DIE K DIE,DA,DR
S X=$O(^ACM(58.1,"B","Complication Onset Dt",0))
I X S DA=X,DIE="^ACM(58.1,",DR=".11///CMP" D ^DIE K DIE,DA,DR
D ^BDMBUL
Q
BDMPOST ; cmi/anch/maw - POST INIT ROUTINE ; [ 08/23/2006 3:21 PM ]
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1**;AUG 11, 2006
+2 ;
ENV ;EP;
+1 ; The following line prevents the "Disable Options..." and "Move
+2 ; Routines..." questions from being asked during the install.
+3 FOR X="XPM1","XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+4 ;I '$$INSTALLD("ACM*2.0*6") D SORRY(2)
+5 QUIT
EN DO REGISTER
+1 QUIT
REGISTER ;CREATE QMAN REGISTER ENTRY
+1 IF $DATA(^AMQQ(7,"B","REGISTER",52))&$DATA(^AMQQ(5,6,"B","CMS REGISTER"))&$DATA(^AMQQ(5,6,"B","REGISTER"))
QUIT
+2 NEW J
+3 SET Z="RTEXT"
+4 FOR J=1:1
SET X=$TEXT(@Z+J)
IF X["END"
QUIT
Begin DoDot:1
+5 SET X=$PIECE(X,";;",2)
+6 SET J=J+1
+7 SET Y=$TEXT(RTEXT+J)
+8 SET Y=$PIECE(Y,";;",2)
+9 SET @X=Y
End DoDot:1
+10 QUIT
ACM421 ;EP;TO CHECK RG MULTIPLE NODE OF THE CMS COMPLICATIONS LIST FILE
+1 ;AND ADD 2000 DIABETES AUDIT TO 'BDMMENU'
+2 NEW X,Y,Z
+3 SET X=0
+4 FOR
SET X=$ORDER(^ACM(42.1,X))
IF 'X
QUIT
Begin DoDot:1
+5 IF $DATA(^ACM(42.1,X,"RG",0))
SET $PIECE(^ACM(42.1,X,"RG",0),U)=""
SET $PIECE(^(0),U,2)="9002241.11P"
End DoDot:1
+6 SET DA(1)=$ORDER(^DIC(19,"B","BDMMENU",0))
+7 SET X=$ORDER(^DIC(19,"B","APCL M MAIN DM MENU",0))
+8 IF 'DA(1)!'X
QUIT
+9 IF '$DATA(^DIC(19,DA(1),10,"B",X))
Begin DoDot:1
+10 KILL DD,DO
+11 SET DIC="^DIC(19,DA(1),10,"
+12 SET DIC(0)="L"
+13 SET DIC("DR")="2////DA"
+14 DO FILE^DICN
End DoDot:1
+15 SET DA=$ORDER(^DIC(19,"B","BDM DIABETES AUDIT",0))
+16 IF 'DA
QUIT
+17 SET DA=$ORDER(^DIC(19,DA(1),10,"B",DA,0))
+18 IF 'DA
QUIT
+19 SET DIK="^DIC(19,"_DA(1)_",10,"
+20 DO ^DIK
+21 KILL DA,DIK,DIC,DR
+22 QUIT
P2 ;EP;
+1 IF $GET(^DIC(2160032,0))["DMS LETTERS"
KILL ^DIC(2160032),^DD(2160032)
+2 DO NEWOP
+3 DO PP
+4 DO COMP
+5 DO DMLAB
P3 ;EP;
P4 ;EP;
+1 DO NEWOP
P5 ;EP;
+1 DO NEWOP
+2 DO ^BDMBUL
+3 QUIT
+4 ;
P6 ;EP;
+1 FOR BDMX="BDM SELF MONITORING REPORT"
Begin DoDot:1
+2 SET BDMY="SMR"
+3 SET X=$$ADD^XPDMENU("BDM REPORTS",BDMX,BDMY)
End DoDot:1
+4 ;
+5 ;
+6 ;NEW TAXONOMY MENU OPTION
+7 ;F BDMX="BDM TAXONOMY SETUP" D
+8 ;.S BDMY="TMS"
+9 ;.S X=$$ADD^XPDMENU("BDM REGISTER MAINTENANCE",BDMX,BDMY)
+10 ;
+11 FOR BDMX="APCL DM2005 DM AUDIT TAX CHECK"
Begin DoDot:1
+12 SET BDMY="D5TC"
+13 SET X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
End DoDot:1
+14 ;
+15 FOR BDMX="APCL DM2005 AUDIT TAX UPDATE"
Begin DoDot:1
+16 SET BDMY="D5TU"
+17 SET X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
End DoDot:1
+18 ;
+19 FOR BDMX="APCL DM2005 PREDIAB TAX CHECK"
Begin DoDot:1
+20 SET BDMY="PDTC"
+21 SET X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
End DoDot:1
+22 ;
+23 FOR BDMX="APCL DM2005 PREDIAB TAX UPDATE"
Begin DoDot:1
+24 SET BDMY="PDTU"
+25 SET X=$$ADD^XPDMENU("BDM TAXONOMY SETUP",BDMX,BDMY)
End DoDot:1
+26 ;
+27 ;
+28 ;S BDMNAME="BDM TAXONOMY SETUP"
+29 ;S BDMOPT=$O(^DIC(19,"B",BDMNAME,0)) Q:'BDMOPT
+30 ;S DIE="^DIC(19,",DA=BDMOPT,DR="15////@;20////@"
+31 ;D ^DIE K DIE,DR,DA
+32 ;
+33 ;D ^BDMBUL6
+34 ;
NEWOPT2 ;MODIFY MAIN MENU EXIT ACTION
+1 ;
+2 SET BDMNAME="BDMMENU"
+3 SET BDMOPT=$ORDER(^DIC(19,"B",BDMNAME,0))
IF 'BDMOPT
QUIT
+4 SET DIE="^DIC(19,"
SET DA=BDMOPT
SET DR="15////"_"D ^BDMKILL"
+5 DO ^DIE
KILL DIE,DR,DA
+6 QUIT
+7 ;
NEWOP ;ADD NEW OPTIONS
+1 FOR BDMX="BDM EDIT PCP"
Begin DoDot:1
+2 SET BDMY="PCP"
+3 SET X=$$ADD^XPDMENU("BDM REGISTER MAINTENANCE",BDMX,BDMY)
End DoDot:1
+4 QUIT
DMLAB ;EP;TO UPDATE PRIMARY PROVIDER AND DM LAB VALUES
+1 SET BDMX="DMS DIABETES LAB REPORT"
+2 IF $DATA(^APCHSCTL("B",BDMX))
SET BDMDA=$ORDER(^APCHSCTL("B",BDMX,0))
+3 IF '$GET(BDMDA)
QUIT
+4 DO DMLAB^BDMFUTIL
+5 QUIT
PP ;EP;TO SYNCHRONIZE PRIMARY PROVIDER WITH FILE 9000001
+1 IF $GET(^DD(9000001,.14,0))'[200
QUIT
+2 SET BDMDA=0
+3 FOR
SET BDMDA=$ORDER(^ACM(41,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+4 WRITE "."
+5 SET PAT=$PIECE(^ACM(41,BDMDA,0),U,2)
+6 IF 'PAT
QUIT
+7 SET PP=$PIECE($GET(^ACM(41,BDMDA,"DT")),U,15)
+8 IF 'PP
QUIT
+9 SET PPP=$PIECE($GET(^AUPNPAT(PAT,0)),U,14)
+10 IF 'PPP
QUIT
+11 IF PP=PPP
QUIT
+12 WRITE "."
+13 SET DA=BDMDA
+14 SET DIE="^ACM(41,"
+15 SET DR="15////"_PPP
+16 DO DIE^BDMFDIC
End DoDot:1
+17 QUIT
COMP ;EP;TO ELIMINATE DUPLICATE COMPLICATIONS
+1 FOR BDMX="CVA (STROKE)","END STAGE RENAL DISEASE","FIXED PROTEINURIA","HIGH RISK FOOT","HYPERTENSION","LASER TX FOR RETINOPATHY","MAJOR AMPUTATION(S)","MINOR AMPUTATION(S)","RETINOPATHY"
Begin DoDot:1
+2 SET (BDMY,BDMZ)=$ORDER(^ACM(42.1,"B",BDMX,0))
+3 IF 'BDMY
QUIT
+4 FOR
SET BDMZ=$ORDER(^ACM(42.1,"B",BDMX,BDMZ))
IF 'BDMZ
QUIT
Begin DoDot:2
+5 SET BDMDA=0
+6 FOR
SET BDMDA=$ORDER(^ACM(42,"B",BDMZ,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:3
+7 SET DA=BDMDA
+8 SET DIE="^ACM(42,"
+9 SET DR=".01///"_BDMY
+10 WRITE "."
+11 DO DIE^BDMFDIC
End DoDot:3
+12 SET DA=BDMZ
+13 SET DIK="^ACM(42.1,"
+14 WRITE "."
+15 DO DIK^BDMFDIC
End DoDot:2
End DoDot:1
+16 QUIT
RTEXT ;;
+1 ;;^AMQQ(5,6,0)
+2 ;;REGISTER^^^52^40^^^^P
+3 ;;^AMQQ(5,6,1,0)
+4 ;;^9009075.01^2^2
+5 ;;^AMQQ(5,6,1,1,0)
+6 ;;REGISTER
+7 ;;^AMQQ(5,6,1,2,0)
+8 ;;CMS REGISTER
+9 ;;^AMQQ(5,6,1,"B","CMS REGISTER",2)
+10 ;;
+11 ;;^AMQQ(5,6,1,"B","REGISTER",1)
+12 ;;
+13 ;;^AMQQ(5,"C","CMS REGISTER",6,2)
+14 ;;
+15 ;;^AMQQ(5,"C","REGISTER",6,1)
+16 ;;
+17 ;;^AMQQ(7,52,0)
+18 ;;REGISTER
+19 ;;^AMQQ(7,"B","REGISTER",52)
+20 ;;
+21 ;;END
+22 ;
INSTALLD(BDMSTAL) ;EP - Determine if patch BDMSTAL was installed, where
+1 ; BDMSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 NEW BDMY,DIC,X,Y
+3 SET X=$PIECE(BDMSTAL,"*",1)
+4 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+5 DO IX^DIC
+6 IF Y<1
DO IMES
QUIT 0
+7 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BDMSTAL,"*",2)
+8 DO ^DIC
+9 IF Y<1
DO IMES
QUIT 0
+10 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BDMSTAL,"*",3)
+11 DO ^DIC
+12 SET BDMY=Y
+13 DO IMES
+14 QUIT $SELECT(BDMY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BDMSTAL_""" 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
V2POST ;EP - called from post init of kids build
+1 NEW X
+2 SET X=$ORDER(^ACM(58.1,"B","Case Comments",0))
+3 IF X
SET DA=X
SET DIE="^ACM(58.1,"
SET DR=".11///@"
DO ^DIE
KILL DIE,DA,DR
+4 SET X=$ORDER(^ACM(58.1,"B","Care Plan Comment",0))
+5 IF X
SET DA=X
SET DIE="^ACM(58.1,"
SET DR=".11///CP"
DO ^DIE
KILL DIE,DA,DR
+6 SET X=$ORDER(^ACM(58.1,"B","Complication Comments",0))
+7 IF X
SET DA=X
SET DIE="^ACM(58.1,"
SET DR=".11///CMP"
DO ^DIE
KILL DIE,DA,DR
+8 SET X=$ORDER(^ACM(58.1,"B","Complication Onset Dt",0))
+9 IF X
SET DA=X
SET DIE="^ACM(58.1,"
SET DR=".11///CMP"
DO ^DIE
KILL DIE,DA,DR
+10 DO ^BDMBUL
+11 QUIT
