BJPC2P7 ; IHS/CMI/LAB - PCC Suite v1.0 patch 3 environment check ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;
;
; 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
;KERNEL
I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
;FILEMAN
I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
;BJPC
I $$VERSION^XPDUTL("BJPC")'="2.0" D MES^XPDUTL($$CJ^XLFSTR("Version 2.0 of the IHS PCC SUITE (BJPC) is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires IHS PCC Suite (BJPC) Version 2.0....Present.",80))
;BJPC 2.0 PATCH 4
I '$$INSTALLD("BJPC*2.0*6") D SORRY(2)
I '$$INSTALLD("APCL*3.0*27") D SORRY(2)
;
Q
;
PRE ;
S DA=0 F S DA=$O(^APCLVSTS(DA)) Q:DA'=+DA S DIK="^APCLVSTS(" D ^DIK
D PRE^AMQQPOST
S DA=$O(^APCHSCMP("B","REFUSALS",0))
I DA S DIE="^APCHSCMP(",DR=".01///REFUSALS/DECLINED SERVICES" D ^DIE
S DA=$O(^APCHSCMP("B","REFUSALS-MOST RECENT OF EACH",0)) I DA S DIE="^APCHSCMP(",DR=".01///REFUSALS/DECLINED SERVICES-MOST RECENT OF EACH" D ^DIE
;
S DA=$O(^APCHSCMP("B","REFUSALS/DECLINED SERVICES",0))
I DA S DIE="^APCHSCMP(",DR="3///REFUSALS/DECLINED SERVICES" D ^DIE
S DA=$O(^APCHSCMP("B","REFUSALS/DECLINED SERVICES-MOS",0))
I DA S DIE="^APCHSCMP(",DR="3///REFUSALS/DECLINED SERVICES-MOST RECENT OF EACH" D ^DIE
S DA=$O(^DIC(19,"APCH PWH UPDATE DEFAULT",0))
I DA S DIE="^DIC(19,",DR="1///Update PWH Site Parameters" D ^DIE K DA,DR,DIE
S DA=$O(^DIC(19,"APCL P REFUSAL LIST",0))
I DA S DIE="^DIC(19,",DR="1///Listing of Patient Declined Services/Refusals" D ^DIE K DA,DR,DIE
S DA=$O(^APCHSCMP("B","REPRODUCTIVE HISTORY",0))
I DA S DIE="^APCHSCMP(",DR=".01///REPRODUCTIVE HISTORY - BRIEF" D ^DIE K DA,DR,DIE
S DA=$O(^APCDTKW("B","EDC",0))
I DA S DIE="^APCDTKW(",DR=".01///EDD;.06///EXPECTED DATE OF DELIVERY" D ^DIE K DA,DR,DIE
S DA=$O(^APCHPWHC("B","EDUCATION FORMS",0))
I DA S DIE="^APCHPWHC(",DR=".01///EDUCATION HANDOUTS" D ^DIE K DA,DR,DIE
S DIU=9000017,DIU(0)="" D EN^DIU2 ;DELETE 9000017, FULL DD SENT IN BUILD
K DIU
Q
POST ;
;ADD EPI OPTIONS
S X=$$ADD^XPDMENU("APCHMENU","APCH GEN SUPPLEMENT","GSUP")
I 'X W !,"Attempt to add APCH GEN SUPPLEMENT option failed.." H 3
S X=$$ADD^XPDMENU("APCD UPD PAT RELATED DATA","APCD PG PATIENT GOALS","PATG")
I 'X W !,"Attempt to add APCD PG PATIENT GOALS option failed.." H 3
S X=$$ADD^XPDMENU("BDP MENU REPORTS","BDP NO DESG PROVIDER","NODP")
I 'X W !,"Attempt to add BDP NO DESG PROVIDER option failed.." H 3
;S X=$$ADD^XPDMENU("APCLMENU","APCM MU MAIN MENU","MUR",3)
;I 'X W !,"Attempt to add APCM MU MAIN MENU option failed.." H 3
;D POST^APCLEM1
D POST^AMQQPOST
S DA=$O(^APCDTKW("B","REF",0))
I DA S DIE="^APCDTKW(",DR=".06///Refused/Declined Service" D ^DIE K DA,DIE,DR
;convert RF EDC to EDD fields and convert Contraceptive Methods to a multiple (2101)
D RFCONV
;HEALTH FACTOR UPDATES
D UPDHF
D ^BJPC27
;update measurement types with .05, .06, .07
F BJPCX="FH","FT","CXD","SN","PR","EGA","AG","EF" D
.S BJPCY=$O(^AUTTMSR("B",BJPCX,0))
.Q:'BJPCY
.S DIE="^AUTTMSR(",DA=BJPCY,DR=".05///F;.06///9;.07///60" D ^DIE K DIE,DA,DR
Q
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BJPCY,DIC,X,Y
S X=$P(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BJPCSTAL,"*",3)
D ^DIC
S BJPCY=Y
D IMES
Q $S(BJPCY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" 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
UPDHF ;
;inactivate HEALTH LITERACY CATEGORY
S DA=$O(^AUTTHF("B","HEALTH LITERACY",0))
I DA S DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;inactivate HEALTH LITERATE
S DA=$O(^AUTTHF("B","HEALTH LITERATE",0))
I DA S DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;inactivate LOW HEALTH LITERACY from the Health Literate category
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","LOW HEALTH LITERACY",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="HEALTH LITERACY"!($$VAL^XBDIQ1(9999999.64,BJPCX,.02)="F081") D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;inactivate any other HEALTH LITERACY items
S BJPCX=0 F S BJPCX=$O(^AUTTHF(BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="HEALTH LITERACY" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;inactivate several Barriers to Learning
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","CHILDHOOD DEVELOPMENT",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","LEARNING DISABILITY",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","DEVELOPMENTAL DELAY",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","<6TH GRADE EDUCATION",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","SOCIAL STRESSORS",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","LESS THAN 6TH GRADE EDUCATION",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;change emotional stressors (STRS) to Stressors (STRESS)
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","EMOTIONAL STRESSORS",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".01///STRESSORS;8801///STRESS" D ^DIE K DA,DIE,DR
;add barriers to learning LOW HEALTH LITERACY AND COGNITIVE IMPAIRMENT
S BJPCX=0 F S BJPCX=$O(^AUTTHF("B","LOW HEALTH LITERACY",BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING" D
.S DA=BJPCX,DIE="^AUTTHF(",DR="8801///LOWLIT" D ^DIE K DA,DIE,DR
;
;inactivate all Rubella Immunity Status HFs
;
S BJPCX=0 F S BJPCX=$O(^AUTTHF(BJPCX)) Q:BJPCX'=+BJPCX I $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="RUBELLA IMMUNITY STATUS" D
.S DA=BJPCX,DIE="^AUTTHF(",DR=".13///1;.15////"_DT D ^DIE K DA,DIE,DR
;now add COGNITIVE IMPAIRMENT
Q:$D(^AUTTHF("C","F120")) ;already there
S BJPCC=$O(^AUTTHF("B","BARRIERS TO LEARNING",0))
S (BJPCX,X)="COGNITIVE IMPAIRMENT",DIC="^AUTTHF(",DIC(0)="L",DIADD=1,DLAYGO=9999999.64,DIC("DR")=".1///F;.03////"_BJPCC_";.02////F120;8801///COGI" D FILE^DICN K DIC,X,DIADD,DLAYGO
I Y=-1 D MES^XPDUTL("Adding Health Factor "_BJPCX_" failed")
Q
RFCONV ;
S BJPCX=0 F S BJPCX=$O(^AUPNREP(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNREP(BJPCX,0)),U,9)="" ;nothing to convert
.;W BJPCX,"~"
.S BJPCEDD=$P(^AUPNREP(BJPCX,0),U,9)
.S BJPCHOW=$P(^AUPNREP(BJPCX,0),U,10)
.I BJPCHOW=""!(BJPCHOW=0) D Q
..S DA=BJPCX,DIE="^AUPNREP(",DR="1314///"_BJPCEDD D ^DIE K DA,DIE,DR
.I BJPCHOW=1 D Q
..S DA=BJPCX,DIE="^AUPNREP(",DR="1305////"_BJPCEDD D ^DIE K DIE,DA,DR
.I BJPCHOW=2 D Q
..S DA=BJPCX,DIE="^AUPNREP(",DR="1302////"_BJPCEDD D ^DIE K DIE,DA,DR
.I BJPCHOW=3 D Q
..S DA=BJPCX,DIE="^AUPNREP(",DR="1308////"_BJPCEDD D ^DIE K DIE,DA,DR
CM ;contraceptive history
S BJPCX=0 F S BJPCX=$O(^AUPNREP(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P(^AUPNREP(BJPCX,0),U,6)="" ;no method to copy to 21 mult
.S BJPCTC=$$VAL^XBDIQ1(9000017,BJPCX,3) ;OLD EXTERNAL SET VALUE (^AUPNREP(BJPCX,0),U,6)
.S BJPCT="",BJPCCOM="" ;NEW VALUE
.S BJPCTE=$$NEWVAL(BJPCTC) ;get external value
.I $P(BJPCTE,U,1)="" D MES^XPDUTL("No conversion value for "_BJPCTC) Q ;no external value
.S BJPCT=$O(^AUTTCM("B",$P(BJPCTE,U,1),0))
.I BJPCT="" D MES^XPDUTL("Error converting "_$P(BJPCTE,U,1)_" ien "_BJPCX) Q
.S BJPCD=$P(^AUPNREP(BJPCX,0),U,7) ;date begun
.I BJPCD Q:$D(^AUPNREP("ACON",BJPCX,BJPCT,BJPCD)) ;already has this one in the multiple
.I 'BJPCD Q:$$HASND(BJPCX,BJPCT) ;already have it with no date
.I $P(BJPCTE,U,2) S BJPCCOM=BJPCTC
.;now create multiple entry
.S DIC="^AUPNREP("_BJPCX_",2101,"
.S DIC(0)="L"
.S DA(1)=BJPCX
.S DIC("P")=$P(^DD(9000017,2101,0),U,2)
.S X=BJPCT
.S DIC("DR")=".02////"_BJPCD_";.06///"_BJPCCOM ;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
.K DD,D0,DO
.D FILE^DICN
.I Y=-1 D MES^XPDUTL("Converting Contraceptive Method for DFN "_BJPCX_" failed.")
.K DIC,DD,DO,D0,DA
Q
;
HASND(X,T) ;DOES THIS PATIENT HAVE THIS ONE WITH NO DATE BEGUN?
NEW Y,G
S G=0
S Y=0 F S Y=$O(^AUPNREP(X,2101,Y)) Q:Y'=+Y I $P(^AUPNREP(X,2101,Y,0),U,1)=T,$P(^AUPNREP(X,2101,Y,0),U,2)="" S G=1
Q G
NEWVAL(E) ;
NEW X,Y,BJPCTEXT,BJPCY
S Y=""
S BJPCTEXT="CMMAP" F BJPCY=1:1 S X=$T(@BJPCTEXT+BJPCY) Q:$P(X,";;",2)=""!(Y]"") I $P(X,";;",2)=E S Y=$P(X,";;",3)_U_$P(X,";;",4)
Q Y
;
CMMAP ;;
;;ABSTINENCE;;ABSTINENCE
;;HORMONE INJECTION;;HORMONAL/DEPO PROVERA
;;HORMONAL IMPLANT;;HORMONAL/IMPLANT
;;MENOPAUSE;;NA MENOPAUSE
;;EDUCATION ONLY;;OTHER;;1
;;ORAL CONTRACEPTIVES;;OTHER;;1
;;IUD;;OTHER;;1
;;BARRIER METHODS;;OTHER;;1
;;OTHER;;OTHER
;;NATURAL TECHNIQUES;;PERIODIC ABSTINENCE METHODS
;;SURGICAL STERILIZATION;;STERILIZATION (FEMALE)
;;PARTNER STERILIZED;;STERILIZATION (MALE)
;;NONE;;NONE
;;
BJPC2P7 ; IHS/CMI/LAB - PCC Suite v1.0 patch 3 environment check ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move Routines..." questions from being asked during the install.
+5 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+7 ;KERNEL
+8 IF +$$VERSION^XPDUTL("XU")<8
DO MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80))
DO SORRY(2)
IF 1
+9 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
+10 ;FILEMAN
+11 IF +$$VERSION^XPDUTL("DI")<22
DO MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80))
DO SORRY(2)
IF 1
+12 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
+13 ;BJPC
+14 IF $$VERSION^XPDUTL("BJPC")'="2.0"
DO MES^XPDUTL($$CJ^XLFSTR("Version 2.0 of the IHS PCC SUITE (BJPC) is required. Not installed",80))
DO SORRY(2)
IF 1
+15 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires IHS PCC Suite (BJPC) Version 2.0....Present.",80))
+16 ;BJPC 2.0 PATCH 4
+17 IF '$$INSTALLD("BJPC*2.0*6")
DO SORRY(2)
+18 IF '$$INSTALLD("APCL*3.0*27")
DO SORRY(2)
+19 ;
+20 QUIT
+21 ;
PRE ;
+1 SET DA=0
FOR
SET DA=$ORDER(^APCLVSTS(DA))
IF DA'=+DA
QUIT
SET DIK="^APCLVSTS("
DO ^DIK
+2 DO PRE^AMQQPOST
+3 SET DA=$ORDER(^APCHSCMP("B","REFUSALS",0))
+4 IF DA
SET DIE="^APCHSCMP("
SET DR=".01///REFUSALS/DECLINED SERVICES"
DO ^DIE
+5 SET DA=$ORDER(^APCHSCMP("B","REFUSALS-MOST RECENT OF EACH",0))
IF DA
SET DIE="^APCHSCMP("
SET DR=".01///REFUSALS/DECLINED SERVICES-MOST RECENT OF EACH"
DO ^DIE
+6 ;
+7 SET DA=$ORDER(^APCHSCMP("B","REFUSALS/DECLINED SERVICES",0))
+8 IF DA
SET DIE="^APCHSCMP("
SET DR="3///REFUSALS/DECLINED SERVICES"
DO ^DIE
+9 SET DA=$ORDER(^APCHSCMP("B","REFUSALS/DECLINED SERVICES-MOS",0))
+10 IF DA
SET DIE="^APCHSCMP("
SET DR="3///REFUSALS/DECLINED SERVICES-MOST RECENT OF EACH"
DO ^DIE
+11 SET DA=$ORDER(^DIC(19,"APCH PWH UPDATE DEFAULT",0))
+12 IF DA
SET DIE="^DIC(19,"
SET DR="1///Update PWH Site Parameters"
DO ^DIE
KILL DA,DR,DIE
+13 SET DA=$ORDER(^DIC(19,"APCL P REFUSAL LIST",0))
+14 IF DA
SET DIE="^DIC(19,"
SET DR="1///Listing of Patient Declined Services/Refusals"
DO ^DIE
KILL DA,DR,DIE
+15 SET DA=$ORDER(^APCHSCMP("B","REPRODUCTIVE HISTORY",0))
+16 IF DA
SET DIE="^APCHSCMP("
SET DR=".01///REPRODUCTIVE HISTORY - BRIEF"
DO ^DIE
KILL DA,DR,DIE
+17 SET DA=$ORDER(^APCDTKW("B","EDC",0))
+18 IF DA
SET DIE="^APCDTKW("
SET DR=".01///EDD;.06///EXPECTED DATE OF DELIVERY"
DO ^DIE
KILL DA,DR,DIE
+19 SET DA=$ORDER(^APCHPWHC("B","EDUCATION FORMS",0))
+20 IF DA
SET DIE="^APCHPWHC("
SET DR=".01///EDUCATION HANDOUTS"
DO ^DIE
KILL DA,DR,DIE
+21 ;DELETE 9000017, FULL DD SENT IN BUILD
SET DIU=9000017
SET DIU(0)=""
DO EN^DIU2
+22 KILL DIU
+23 QUIT
POST ;
+1 ;ADD EPI OPTIONS
+2 SET X=$$ADD^XPDMENU("APCHMENU","APCH GEN SUPPLEMENT","GSUP")
+3 IF 'X
WRITE !,"Attempt to add APCH GEN SUPPLEMENT option failed.."
HANG 3
+4 SET X=$$ADD^XPDMENU("APCD UPD PAT RELATED DATA","APCD PG PATIENT GOALS","PATG")
+5 IF 'X
WRITE !,"Attempt to add APCD PG PATIENT GOALS option failed.."
HANG 3
+6 SET X=$$ADD^XPDMENU("BDP MENU REPORTS","BDP NO DESG PROVIDER","NODP")
+7 IF 'X
WRITE !,"Attempt to add BDP NO DESG PROVIDER option failed.."
HANG 3
+8 ;S X=$$ADD^XPDMENU("APCLMENU","APCM MU MAIN MENU","MUR",3)
+9 ;I 'X W !,"Attempt to add APCM MU MAIN MENU option failed.." H 3
+10 ;D POST^APCLEM1
+11 DO POST^AMQQPOST
+12 SET DA=$ORDER(^APCDTKW("B","REF",0))
+13 IF DA
SET DIE="^APCDTKW("
SET DR=".06///Refused/Declined Service"
DO ^DIE
KILL DA,DIE,DR
+14 ;convert RF EDC to EDD fields and convert Contraceptive Methods to a multiple (2101)
+15 DO RFCONV
+16 ;HEALTH FACTOR UPDATES
+17 DO UPDHF
+18 DO ^BJPC27
+19 ;update measurement types with .05, .06, .07
+20 FOR BJPCX="FH","FT","CXD","SN","PR","EGA","AG","EF"
Begin DoDot:1
+21 SET BJPCY=$ORDER(^AUTTMSR("B",BJPCX,0))
+22 IF 'BJPCY
QUIT
+23 SET DIE="^AUTTMSR("
SET DA=BJPCY
SET DR=".05///F;.06///9;.07///60"
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+24 QUIT
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BJPCY,DIC,X,Y
+4 SET X=$PIECE(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BJPCSTAL,"*",3)
+12 DO ^DIC
+13 SET BJPCY=Y
+14 DO IMES
+15 QUIT $SELECT(BJPCY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" 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
UPDHF ;
+1 ;inactivate HEALTH LITERACY CATEGORY
+2 SET DA=$ORDER(^AUTTHF("B","HEALTH LITERACY",0))
+3 IF DA
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
+4 ;inactivate HEALTH LITERATE
+5 SET DA=$ORDER(^AUTTHF("B","HEALTH LITERATE",0))
+6 IF DA
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
+7 ;inactivate LOW HEALTH LITERACY from the Health Literate category
+8 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","LOW HEALTH LITERACY",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="HEALTH LITERACY"!($$VAL^XBDIQ1(9999999.64,BJPCX,.02)="F081")
Begin DoDot:1
+9 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+10 ;inactivate any other HEALTH LITERACY items
+11 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF(BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="HEALTH LITERACY"
Begin DoDot:1
+12 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+13 ;inactivate several Barriers to Learning
+14 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","CHILDHOOD DEVELOPMENT",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+15 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+16 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","LEARNING DISABILITY",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+17 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+18 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","DEVELOPMENTAL DELAY",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+19 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+20 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","<6TH GRADE EDUCATION",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+21 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+22 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","SOCIAL STRESSORS",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+23 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+24 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","LESS THAN 6TH GRADE EDUCATION",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+25 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+26 ;change emotional stressors (STRS) to Stressors (STRESS)
+27 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","EMOTIONAL STRESSORS",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+28 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".01///STRESSORS;8801///STRESS"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+29 ;add barriers to learning LOW HEALTH LITERACY AND COGNITIVE IMPAIRMENT
+30 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF("B","LOW HEALTH LITERACY",BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="BARRIERS TO LEARNING"
Begin DoDot:1
+31 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR="8801///LOWLIT"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+32 ;
+33 ;inactivate all Rubella Immunity Status HFs
+34 ;
+35 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUTTHF(BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF $$VAL^XBDIQ1(9999999.64,BJPCX,.03)="RUBELLA IMMUNITY STATUS"
Begin DoDot:1
+36 SET DA=BJPCX
SET DIE="^AUTTHF("
SET DR=".13///1;.15////"_DT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+37 ;now add COGNITIVE IMPAIRMENT
+38 ;already there
IF $DATA(^AUTTHF("C","F120"))
QUIT
+39 SET BJPCC=$ORDER(^AUTTHF("B","BARRIERS TO LEARNING",0))
+40 SET (BJPCX,X)="COGNITIVE IMPAIRMENT"
SET DIC="^AUTTHF("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9999999.64
SET DIC("DR")=".1///F;.03////"_BJPCC_";.02////F120;8801///COGI"
DO FILE^DICN
KILL DIC,X,DIADD,DLAYGO
+41 IF Y=-1
DO MES^XPDUTL("Adding Health Factor "_BJPCX_" failed")
+42 QUIT
RFCONV ;
+1 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNREP(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+2 ;nothing to convert
IF $PIECE($GET(^AUPNREP(BJPCX,0)),U,9)=""
QUIT
+3 ;W BJPCX,"~"
+4 SET BJPCEDD=$PIECE(^AUPNREP(BJPCX,0),U,9)
+5 SET BJPCHOW=$PIECE(^AUPNREP(BJPCX,0),U,10)
+6 IF BJPCHOW=""!(BJPCHOW=0)
Begin DoDot:2
+7 SET DA=BJPCX
SET DIE="^AUPNREP("
SET DR="1314///"_BJPCEDD
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
QUIT
+8 IF BJPCHOW=1
Begin DoDot:2
+9 SET DA=BJPCX
SET DIE="^AUPNREP("
SET DR="1305////"_BJPCEDD
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
QUIT
+10 IF BJPCHOW=2
Begin DoDot:2
+11 SET DA=BJPCX
SET DIE="^AUPNREP("
SET DR="1302////"_BJPCEDD
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
QUIT
+12 IF BJPCHOW=3
Begin DoDot:2
+13 SET DA=BJPCX
SET DIE="^AUPNREP("
SET DR="1308////"_BJPCEDD
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
QUIT
End DoDot:1
CM ;contraceptive history
+1 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNREP(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+2 ;no method to copy to 21 mult
IF $PIECE(^AUPNREP(BJPCX,0),U,6)=""
QUIT
+3 ;OLD EXTERNAL SET VALUE (^AUPNREP(BJPCX,0),U,6)
SET BJPCTC=$$VAL^XBDIQ1(9000017,BJPCX,3)
+4 ;NEW VALUE
SET BJPCT=""
SET BJPCCOM=""
+5 ;get external value
SET BJPCTE=$$NEWVAL(BJPCTC)
+6 ;no external value
IF $PIECE(BJPCTE,U,1)=""
DO MES^XPDUTL("No conversion value for "_BJPCTC)
QUIT
+7 SET BJPCT=$ORDER(^AUTTCM("B",$PIECE(BJPCTE,U,1),0))
+8 IF BJPCT=""
DO MES^XPDUTL("Error converting "_$PIECE(BJPCTE,U,1)_" ien "_BJPCX)
QUIT
+9 ;date begun
SET BJPCD=$PIECE(^AUPNREP(BJPCX,0),U,7)
+10 ;already has this one in the multiple
IF BJPCD
IF $DATA(^AUPNREP("ACON",BJPCX,BJPCT,BJPCD))
QUIT
+11 ;already have it with no date
IF 'BJPCD
IF $$HASND(BJPCX,BJPCT)
QUIT
+12 IF $PIECE(BJPCTE,U,2)
SET BJPCCOM=BJPCTC
+13 ;now create multiple entry
+14 SET DIC="^AUPNREP("_BJPCX_",2101,"
+15 SET DIC(0)="L"
+16 SET DA(1)=BJPCX
+17 SET DIC("P")=$PIECE(^DD(9000017,2101,0),U,2)
+18 SET X=BJPCT
+19 ;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
SET DIC("DR")=".02////"_BJPCD_";.06///"_BJPCCOM
+20 KILL DD,D0,DO
+21 DO FILE^DICN
+22 IF Y=-1
DO MES^XPDUTL("Converting Contraceptive Method for DFN "_BJPCX_" failed.")
+23 KILL DIC,DD,DO,D0,DA
End DoDot:1
+24 QUIT
+25 ;
HASND(X,T) ;DOES THIS PATIENT HAVE THIS ONE WITH NO DATE BEGUN?
+1 NEW Y,G
+2 SET G=0
+3 SET Y=0
FOR
SET Y=$ORDER(^AUPNREP(X,2101,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AUPNREP(X,2101,Y,0),U,1)=T
IF $PIECE(^AUPNREP(X,2101,Y,0),U,2)=""
SET G=1
+4 QUIT G
NEWVAL(E) ;
+1 NEW X,Y,BJPCTEXT,BJPCY
+2 SET Y=""
+3 SET BJPCTEXT="CMMAP"
FOR BJPCY=1:1
SET X=$TEXT(@BJPCTEXT+BJPCY)
IF $PIECE(X,";;",2)=""!(Y]"")
QUIT
IF $PIECE(X,";;",2)=E
SET Y=$PIECE(X,";;",3)_U_$PIECE(X,";;",4)
+4 QUIT Y
+5 ;
CMMAP ;;
+1 ;;ABSTINENCE;;ABSTINENCE
+2 ;;HORMONE INJECTION;;HORMONAL/DEPO PROVERA
+3 ;;HORMONAL IMPLANT;;HORMONAL/IMPLANT
+4 ;;MENOPAUSE;;NA MENOPAUSE
+5 ;;EDUCATION ONLY;;OTHER;;1
+6 ;;ORAL CONTRACEPTIVES;;OTHER;;1
+7 ;;IUD;;OTHER;;1
+8 ;;BARRIER METHODS;;OTHER;;1
+9 ;;OTHER;;OTHER
+10 ;;NATURAL TECHNIQUES;;PERIODIC ABSTINENCE METHODS
+11 ;;SURGICAL STERILIZATION;;STERILIZATION (FEMALE)
+12 ;;PARTNER STERILIZED;;STERILIZATION (MALE)
+13 ;;NONE;;NONE
+14 ;;
