BSTS10P2 ;GDIT/HS/BEE-Version 1.0 Patch 2 Post (and Pre) Install ; 19 Nov 2012 9:41 AM
;;1.0;IHS STANDARD TERMINOLOGY;**2**;Sep 10, 2014;Build 59
;
ENV ;EP - Environmental Checking Routine
;
;Check for Version 1.0
I $$VERSION^XPDUTL("BSTS")<1 D BMES^XPDUTL("Version 1.0 of BSTS is required!") S XPDQUIT=2 Q
;
;Make sure a refresh is not running already
L +^BSTS(9002318.1,0):0 E D BMES^XPDUTL("A Local BSTS Cache Refresh is Already Running. Please Try Later") S XPDQUIT=2 Q
L -^BSTS(9002318.1,0)
;
;Make sure an ICD9 to SNOMED compile isn't running
L +^TMP("BSTSICD2SMD"):0 E D BMES^XPDUTL("An ICD9 to SNOMED Background Compile is Running. Please Try later") S XPDQUIT=2 Q
L -^TMP("BSTSICD2SMD")
;
;Make sure another install isn't running
L +^TMP("BSTSINSTALL"):3 E D BMES^XPDUTL("A BSTS Install is Already Running") S XPDQUIT=2 Q
L -^TMP("BSTSINSTALL")
;
Q
;
EN ;EP Patch 2 Post Install Front End
;
;Set up the site parameter entry
NEW DIC,DLAYGO,X,Y,TRIEN,EXEC,ERR,KIDS
S DIC(0)="LNZ",DIC="^BSTS(9002318,",DLAYGO=9002318,X=$P($G(^AUTTSITE(1,0)),U,1)
I X="" S X=$O(^BGPSITE(0))
I X'="" S X=$P(^DIC(4,X,0),U,1)
D ^DIC
;
;Update LAST SUBSET CHECK now so process won't keep getting called
D
. NEW BSTS,ERROR,NMIEN
. S NMIEN=$O(^BSTS(9002318.1,"B",36,"")) Q:NMIEN=""
. S BSTS(9002318.1,NMIEN_",",.06)=DT
. D FILE^DIE("","BSTS","ERROR")
;
;Load the classes
;
;For each build, set this to the 9002318.5 entry to load
S TRIEN=1
;
;Delete existing BSTS Classes
S EXEC="DO $SYSTEM.OBJ.DeletePackage(""BSTS"")" X EXEC
;
; Import BSTS classes
K ERR
I $G(TRIEN)'="" D IMPORT^BSTSCLAS(TRIEN,.ERR)
;
;Unlock installation entry
L -^TMP("BSTSINSTALL")
;
;Display install message
D BMES^XPDUTL("Kicking off ICD9 to SNOMED and PROBLEM/FH conversion processes")
;
S KIDS=1
RESTART ;Perform version check - to see if DTS works with the possible new ports
;Restart from here if check below fails
;
NEW STS,VAR
S STS=$$VERSIONS^BSTSAPI("VAR",36)
I (+STS'=2)!$G(ERR) D W !!,"DTS is not working properly. Please contact the BSTS Support Group - Aborting Installation" H 10 S XPDABORT=1 Q
. ;
. ;Quit if a restart
. Q:'$G(KIDS)
. ;
. ;Allow logins again
. NEW LIEN,LOG,ERR
. S LIEN=$O(^%ZIS(14.5,0)) Q:'+LIEN
. S LOG(14.5,LIEN_",",1)="N"
. D FILE^DIE("","LOG","ERR")
;
;Kick off process to convert problems and family history
K ^XTMP("BSTSLCMP","QUIT") ;Reset quit flag
D
. NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSK
. ;
. ;Perform version check - to see if DTS works with the possible new ports
. ;
. L +^TMP("BSTSPBFH"):0 E Q ;Already running
. L -^TMP("BSTSPBFH")
. ;
. ;Queue the process off in the background
. K IO("Q")
. ;
. S ZTRTN="PBFH^BSTS10P2",ZTDESC="BSTS - Convert Problems and Family History"
. S ZTIO=""
. S ZTDTH=$H
. D ^%ZTLOAD
;
;Clear out the ICD9 to SNOMED JOB flag and kick off process
D
. NEW BSTSUPD,ERR,NMIEN
. ;
. ;Make sure we have a codeset (namespace)
. S NMIEN=$O(^BSTS(9002318.1,"B",36,"")) Q:NMIEN=""
. S BSTSUPD(9002318.1,NMIEN_",",.09)="@"
. D FILE^DIE("","BSTSUPD","ERR")
. Q:$D(ERR)
. ;
. ;Kick off the background process
. D PLOAD^BSTSUTIL(NMIEN)
;
Q
;
PRE ;Pre-Install Front End
;
NEW DIU,WSIEN
;
;Perform Lock so only one install can run and DTS calls will be switched to local
L +^TMP("BSTSINSTALL"):3 E W !!,"A BSTS Install is Already Running - Aborting Installation" H 10 S XPDABORT=1 Q
;
;Check Web Service entries - convert old ports to new ports
NEW WSIEN,APCDX,STS
;
S WSIEN=0 F S WSIEN=$O(^BSTS(9002318.2,WSIEN)) Q:'WSIEN D
. NEW PORT,NWPORT,BSTSUPD,ERR
. ;
. ;Get the port - Quit it old DITDTS1 or Production port not found
. S PORT=$$GET1^DIQ(9002318.2,WSIEN_",",.03,"E") Q:PORT=""
. S NWPORT=PORT
. ;
. ;Production
. I (PORT=443)!(PORT=444)!(PORT=445) S NWPORT=42102
. ;
. ;DITDTS1
. I (PORT=8080)!(PORT=8081) S NWPORT=8082
. ;
. ;Update the service patch
. S BSTSUPD(9002318.2,WSIEN_",",.11)="/soap"
. ;
. ;Update the port
. I NWPORT'=PORT S BSTSUPD(9002318.2,WSIEN_",",.03)=NWPORT
. ;
. ;Update the entry
. D FILE^DIE("","BSTSUPD","ERR")
;
;Clear out existing entries
S DIU="^BSTS(9002318.1,",DIU(0)="DST" D EN^DIU2
S DIU="^BSTS(9002318.3,",DIU(0)="DST" D EN^DIU2
S DIU="^BSTS(9002318.4,",DIU(0)="DST" D EN^DIU2
S DIU="^BSTSCLS(",DIU(0)="DST" D EN^DIU2
Q
;
PBFH ;This section converts the problem and family history files to the new mappings
;
NEW X1,X2,VAR,STS,X
;
K ^XTMP("BSTSPBFH")
;
;Get a later date
S X1=DT,X2=60 D C^%DTC
S ^XTMP("BSTSPBFH")=X_U_DT_U_"Patch 2 problem/family history conversion started"
;
;Perform lock
L +^TMP("BSTSPBFH"):0 E S $P(^XTMP("BSTSPBFH"),U,3)="Patch 2 problem/family history conversion already running" Q
;
;Perform version check - to see if DTS works with the possible new ports
S STS=$$VERSIONS^BSTSAPI("VAR",36)
I +STS'=2 D G XPBFH
. S $P(^XTMP("BSTSPBFH"),U,3)="DTS not working - conversion failed"
;
;Adapted from Lori's APCDPLFH routine which will run on 10/1/15 and convert ICD9
;entries to ICD10 entries in the problem and family history files. Due to incorrect
;mappings delivered with BSTS v1.0, problem and family history entries may have
;incorrect ICD9 values. This conversion will look at each file entry, pull the correct
;ICD9 value from BSTS and use that instead.
;
NEW APCDX
;
;Do not perform conversion if after 9/30/2015
I DT>3150930 S $P(^XTMP("BSTSPBFH"),U,3)="DT is after 3150930 - conversion aborted" G XPBFH
;
S APCDX=0
F S APCDX=$O(^AUPNPROB(APCDX)) Q:APCDX'=+APCDX D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. ;
. ;Update log entry
. S $P(^XTMP("BSTSPBFH"),U,3)="Converting problem entry: "_APCDX
. ;
. NEW APCDCI,APCDICDS,APCDO01,APCDOA,X,Y,APCDN01,APCDNA,APCDLOGE
. NEW APCDZ,APCDFNUM,APCDNODE,APCDY
. Q:'$D(^AUPNPROB(APCDX,0))
. S APCDCI=$P($G(^AUPNPROB(APCDX,800)),U) ;only snomed coded problems
. Q:APCDCI=""
. S ^XTMP("BSTSPBFH","P",APCDX)="" ;Log entry
. Q:$P(^AUPNPROB(APCDX,0),U,12)="D" ;SKIP DELETED PROBLEMS
. S APCDICDS=$P($$CONC^BSTSAPI(APCDCI_"^^^1"),U,5) ;ALL ICD CODES
. S APCDO01=$P(^AUPNPROB(APCDX,0),U,1) ;old .01
. S APCDOA="" ;old additional, ":" delimited
. S X=0 F S X=$O(^AUPNPROB(APCDX,12,X)) Q:X'=+X D
.. S Y=$P($G(^AUPNPROB(APCDX,12,X,0)),U)
.. Q:'Y
.. S Y=$P($$ICDDX^ICDCODE(Y),U,2)
.. S APCDOA=APCDOA_Y_":"
. ;update PROBLEM entry
. S APCDN01=$P(APCDICDS,";") S:APCDN01'["." APCDN01=APCDN01_"."
. I APCDN01="" S APCDN01=".9999" ;Default to .9999 if no map
. S:APCDN01'["." APCDN01=APCDN01_"."
. S APCDN01=+$$CODEN^ICDCODE(APCDN01,80)
. I 'APCDN01 Q
. I APCDN01=-1 Q ;Can't change it if it isn't in file 80
. S APCDNA=$P(APCDICDS,";",2,999) ;new additional codes
. ;now set AUPNPROB
. K DIE,DA,DR S DA=APCDX,DR=".01////"_APCDN01,DIE="^AUPNPROB(" D ^DIE K DIE,DA,DR
. ;ADDITIONAL MULTIPLE
. ;DELETE OUT OLD ADDITIONAL MULTIPLE
. S APCDZ=0 F S APCDZ=$O(^AUPNPROB(APCDX,12,APCDZ)) Q:APCDZ'=+APCDZ D
.. NEW DIE,DA,DR
.. S DIE="^AUPNPROB("_APCDX_",12,",DA=APCDZ,DA(1)=APCDX,DR=".01///@" D ^DIE
. ;SET 12 NODES
. S APCDFNUM=9000011.12
. S APCDNODE=12
. F APCDZ=1:1 S APCDY=$P(APCDNA,";",APCDZ) Q:APCDY="" D
.. NEW APCDP,APCDFDA,ERR
.. S:APCDY'["." APCDY=APCDY_"."
.. S APCDP=+$$CODEN^ICDCODE(APCDY,80)
..Q:'APCDP
..Q:APCDP=-1
..S APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
..D UPDATE^DIE("","APCDFDA","","ERR")
;
FH ;
S APCDX=0
F S APCDX=$O(^AUPNFH(APCDX)) Q:APCDX'=+APCDX D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. ;
. ;Update log entry
. S $P(^XTMP("BSTSPBFH"),U,3)="Converting family history entry: "_APCDX
. ;
. NEW APCDCI,APCDICDS,APCDO01,APCDOA,X,Y,APCDN01,APCDNA,APCDLOGE
. NEW APCDZ,APCDFNUM,APCDY
. Q:'$D(^AUPNFH(APCDX,0))
. S APCDCI=$P($G(^AUPNFH(APCDX,0)),U,13) ;only snomed coded fh ENTRIES
. Q:APCDCI=""
. S ^XTMP("BSTSPBFH","F",APCDX)="" ;Log entry
. S APCDICDS=$P($$CONC^BSTSAPI(APCDCI_"^^^1"),U,5) ;ALL ICD CODES
. S APCDO01=$P(^AUPNFH(APCDX,0),U,1)
. S APCDOA=""
. S X=0 F S X=$O(^AUPNFH(APCDX,11,X)) Q:X'=+X D
.. S Y=$P($G(^AUPNFH(APCDX,11,X,0)),U)
.. Q:'Y
.. S Y=$P($$ICDDX^ICDCODE(Y),U,2)
.. S APCDOA=APCDOA_Y_":"
. ;update fh entry
. S APCDN01=$P(APCDICDS,";")
. I APCDN01="" S APCDN01=".9999" ;Default to .9999 if no map
. S:APCDN01'["." APCDN01=APCDN01_"."
. S APCDN01=+$$CODEN^ICDCODE(APCDN01,80)
. I 'APCDN01 Q
. I APCDN01=-1 Q
. S APCDNA=$P(APCDICDS,";",2,999)
. ;now set AUPNFH
. K DIE,DA,DR S DA=APCDX,DR=".01////"_APCDN01,DIE="^AUPNFH(" D ^DIE K DIE,DA,DR
. S APCDZ=0 F S APCDZ=$O(^AUPNFH(APCDX,11,APCDZ)) Q:APCDZ'=+APCDZ D
.. S DIE="^AUPNFH("_APCDX_",11,",DA=APCDZ,DA(1)=APCDX,DR=".01///@" D ^DIE K DIE,DA,DR
. ;SET 11 NODES
. S APCDFNUM=9000014.11
. F APCDZ=1:1 S APCDY=$P(APCDNA,";",APCDZ) Q:APCDY="" D
.. NEW APCDP,APCDFDA,ERR
.. S:APCDY'["." APCDY=APCDY_"."
.. S APCDP=+$$CODEN^ICDCODE(APCDY,80)
.. Q:'APCDP
.. Q:APCDP=-1
.. S APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
.. D UPDATE^DIE("","APCDFDA","","ERR")
;
;Update log entry
S $P(^XTMP("BSTSPBFH"),U,3)="Patch 2 problem/family history conversion completed"
;
;Remove lock
XPBFH L -^TMP("BSTSPBFH")
;
Q
BSTS10P2 ;GDIT/HS/BEE-Version 1.0 Patch 2 Post (and Pre) Install ; 19 Nov 2012 9:41 AM
+1 ;;1.0;IHS STANDARD TERMINOLOGY;**2**;Sep 10, 2014;Build 59
+2 ;
ENV ;EP - Environmental Checking Routine
+1 ;
+2 ;Check for Version 1.0
+3 IF $$VERSION^XPDUTL("BSTS")<1
DO BMES^XPDUTL("Version 1.0 of BSTS is required!")
SET XPDQUIT=2
QUIT
+4 ;
+5 ;Make sure a refresh is not running already
+6 LOCK +^BSTS(9002318.1,0):0
IF '$TEST
DO BMES^XPDUTL("A Local BSTS Cache Refresh is Already Running. Please Try Later")
SET XPDQUIT=2
QUIT
+7 LOCK -^BSTS(9002318.1,0)
+8 ;
+9 ;Make sure an ICD9 to SNOMED compile isn't running
+10 LOCK +^TMP("BSTSICD2SMD"):0
IF '$TEST
DO BMES^XPDUTL("An ICD9 to SNOMED Background Compile is Running. Please Try later")
SET XPDQUIT=2
QUIT
+11 LOCK -^TMP("BSTSICD2SMD")
+12 ;
+13 ;Make sure another install isn't running
+14 LOCK +^TMP("BSTSINSTALL"):3
IF '$TEST
DO BMES^XPDUTL("A BSTS Install is Already Running")
SET XPDQUIT=2
QUIT
+15 LOCK -^TMP("BSTSINSTALL")
+16 ;
+17 QUIT
+18 ;
EN ;EP Patch 2 Post Install Front End
+1 ;
+2 ;Set up the site parameter entry
+3 NEW DIC,DLAYGO,X,Y,TRIEN,EXEC,ERR,KIDS
+4 SET DIC(0)="LNZ"
SET DIC="^BSTS(9002318,"
SET DLAYGO=9002318
SET X=$PIECE($GET(^AUTTSITE(1,0)),U,1)
+5 IF X=""
SET X=$ORDER(^BGPSITE(0))
+6 IF X'=""
SET X=$PIECE(^DIC(4,X,0),U,1)
+7 DO ^DIC
+8 ;
+9 ;Update LAST SUBSET CHECK now so process won't keep getting called
+10 Begin DoDot:1
+11 NEW BSTS,ERROR,NMIEN
+12 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",36,""))
IF NMIEN=""
QUIT
+13 SET BSTS(9002318.1,NMIEN_",",.06)=DT
+14 DO FILE^DIE("","BSTS","ERROR")
End DoDot:1
+15 ;
+16 ;Load the classes
+17 ;
+18 ;For each build, set this to the 9002318.5 entry to load
+19 SET TRIEN=1
+20 ;
+21 ;Delete existing BSTS Classes
+22 SET EXEC="DO $SYSTEM.OBJ.DeletePackage(""BSTS"")"
XECUTE EXEC
+23 ;
+24 ; Import BSTS classes
+25 KILL ERR
+26 IF $GET(TRIEN)'=""
DO IMPORT^BSTSCLAS(TRIEN,.ERR)
+27 ;
+28 ;Unlock installation entry
+29 LOCK -^TMP("BSTSINSTALL")
+30 ;
+31 ;Display install message
+32 DO BMES^XPDUTL("Kicking off ICD9 to SNOMED and PROBLEM/FH conversion processes")
+33 ;
+34 SET KIDS=1
RESTART ;Perform version check - to see if DTS works with the possible new ports
+1 ;Restart from here if check below fails
+2 ;
+3 NEW STS,VAR
+4 SET STS=$$VERSIONS^BSTSAPI("VAR",36)
+5 IF (+STS'=2)!$GET(ERR)
Begin DoDot:1
+6 ;
+7 ;Quit if a restart
+8 IF '$GET(KIDS)
QUIT
+9 ;
+10 ;Allow logins again
+11 NEW LIEN,LOG,ERR
+12 SET LIEN=$ORDER(^%ZIS(14.5,0))
IF '+LIEN
QUIT
+13 SET LOG(14.5,LIEN_",",1)="N"
+14 DO FILE^DIE("","LOG","ERR")
End DoDot:1
WRITE !!,"DTS is not working properly. Please contact the BSTS Support Group - Aborting Installation"
HANG 10
SET XPDABORT=1
QUIT
+15 ;
+16 ;Kick off process to convert problems and family history
+17 ;Reset quit flag
KILL ^XTMP("BSTSLCMP","QUIT")
+18 Begin DoDot:1
+19 NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSK
+20 ;
+21 ;Perform version check - to see if DTS works with the possible new ports
+22 ;
+23 ;Already running
LOCK +^TMP("BSTSPBFH"):0
IF '$TEST
QUIT
+24 LOCK -^TMP("BSTSPBFH")
+25 ;
+26 ;Queue the process off in the background
+27 KILL IO("Q")
+28 ;
+29 SET ZTRTN="PBFH^BSTS10P2"
SET ZTDESC="BSTS - Convert Problems and Family History"
+30 SET ZTIO=""
+31 SET ZTDTH=$HOROLOG
+32 DO ^%ZTLOAD
End DoDot:1
+33 ;
+34 ;Clear out the ICD9 to SNOMED JOB flag and kick off process
+35 Begin DoDot:1
+36 NEW BSTSUPD,ERR,NMIEN
+37 ;
+38 ;Make sure we have a codeset (namespace)
+39 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",36,""))
IF NMIEN=""
QUIT
+40 SET BSTSUPD(9002318.1,NMIEN_",",.09)="@"
+41 DO FILE^DIE("","BSTSUPD","ERR")
+42 IF $DATA(ERR)
QUIT
+43 ;
+44 ;Kick off the background process
+45 DO PLOAD^BSTSUTIL(NMIEN)
End DoDot:1
+46 ;
+47 QUIT
+48 ;
PRE ;Pre-Install Front End
+1 ;
+2 NEW DIU,WSIEN
+3 ;
+4 ;Perform Lock so only one install can run and DTS calls will be switched to local
+5 LOCK +^TMP("BSTSINSTALL"):3
IF '$TEST
WRITE !!,"A BSTS Install is Already Running - Aborting Installation"
HANG 10
SET XPDABORT=1
QUIT
+6 ;
+7 ;Check Web Service entries - convert old ports to new ports
+8 NEW WSIEN,APCDX,STS
+9 ;
+10 SET WSIEN=0
FOR
SET WSIEN=$ORDER(^BSTS(9002318.2,WSIEN))
IF 'WSIEN
QUIT
Begin DoDot:1
+11 NEW PORT,NWPORT,BSTSUPD,ERR
+12 ;
+13 ;Get the port - Quit it old DITDTS1 or Production port not found
+14 SET PORT=$$GET1^DIQ(9002318.2,WSIEN_",",.03,"E")
IF PORT=""
QUIT
+15 SET NWPORT=PORT
+16 ;
+17 ;Production
+18 IF (PORT=443)!(PORT=444)!(PORT=445)
SET NWPORT=42102
+19 ;
+20 ;DITDTS1
+21 IF (PORT=8080)!(PORT=8081)
SET NWPORT=8082
+22 ;
+23 ;Update the service patch
+24 SET BSTSUPD(9002318.2,WSIEN_",",.11)="/soap"
+25 ;
+26 ;Update the port
+27 IF NWPORT'=PORT
SET BSTSUPD(9002318.2,WSIEN_",",.03)=NWPORT
+28 ;
+29 ;Update the entry
+30 DO FILE^DIE("","BSTSUPD","ERR")
End DoDot:1
+31 ;
+32 ;Clear out existing entries
+33 SET DIU="^BSTS(9002318.1,"
SET DIU(0)="DST"
DO EN^DIU2
+34 SET DIU="^BSTS(9002318.3,"
SET DIU(0)="DST"
DO EN^DIU2
+35 SET DIU="^BSTS(9002318.4,"
SET DIU(0)="DST"
DO EN^DIU2
+36 SET DIU="^BSTSCLS("
SET DIU(0)="DST"
DO EN^DIU2
+37 QUIT
+38 ;
PBFH ;This section converts the problem and family history files to the new mappings
+1 ;
+2 NEW X1,X2,VAR,STS,X
+3 ;
+4 KILL ^XTMP("BSTSPBFH")
+5 ;
+6 ;Get a later date
+7 SET X1=DT
SET X2=60
DO C^%DTC
+8 SET ^XTMP("BSTSPBFH")=X_U_DT_U_"Patch 2 problem/family history conversion started"
+9 ;
+10 ;Perform lock
+11 LOCK +^TMP("BSTSPBFH"):0
IF '$TEST
SET $PIECE(^XTMP("BSTSPBFH"),U,3)="Patch 2 problem/family history conversion already running"
QUIT
+12 ;
+13 ;Perform version check - to see if DTS works with the possible new ports
+14 SET STS=$$VERSIONS^BSTSAPI("VAR",36)
+15 IF +STS'=2
Begin DoDot:1
+16 SET $PIECE(^XTMP("BSTSPBFH"),U,3)="DTS not working - conversion failed"
End DoDot:1
GOTO XPBFH
+17 ;
+18 ;Adapted from Lori's APCDPLFH routine which will run on 10/1/15 and convert ICD9
+19 ;entries to ICD10 entries in the problem and family history files. Due to incorrect
+20 ;mappings delivered with BSTS v1.0, problem and family history entries may have
+21 ;incorrect ICD9 values. This conversion will look at each file entry, pull the correct
+22 ;ICD9 value from BSTS and use that instead.
+23 ;
+24 NEW APCDX
+25 ;
+26 ;Do not perform conversion if after 9/30/2015
+27 IF DT>3150930
SET $PIECE(^XTMP("BSTSPBFH"),U,3)="DT is after 3150930 - conversion aborted"
GOTO XPBFH
+28 ;
+29 SET APCDX=0
+30 FOR
SET APCDX=$ORDER(^AUPNPROB(APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+31 ;
+32 ;Update log entry
+33 SET $PIECE(^XTMP("BSTSPBFH"),U,3)="Converting problem entry: "_APCDX
+34 ;
+35 NEW APCDCI,APCDICDS,APCDO01,APCDOA,X,Y,APCDN01,APCDNA,APCDLOGE
+36 NEW APCDZ,APCDFNUM,APCDNODE,APCDY
+37 IF '$DATA(^AUPNPROB(APCDX,0))
QUIT
+38 ;only snomed coded problems
SET APCDCI=$PIECE($GET(^AUPNPROB(APCDX,800)),U)
+39 IF APCDCI=""
QUIT
+40 ;Log entry
SET ^XTMP("BSTSPBFH","P",APCDX)=""
+41 ;SKIP DELETED PROBLEMS
IF $PIECE(^AUPNPROB(APCDX,0),U,12)="D"
QUIT
+42 ;ALL ICD CODES
SET APCDICDS=$PIECE($$CONC^BSTSAPI(APCDCI_"^^^1"),U,5)
+43 ;old .01
SET APCDO01=$PIECE(^AUPNPROB(APCDX,0),U,1)
+44 ;old additional, ":" delimited
SET APCDOA=""
+45 SET X=0
FOR
SET X=$ORDER(^AUPNPROB(APCDX,12,X))
IF X'=+X
QUIT
Begin DoDot:2
+46 SET Y=$PIECE($GET(^AUPNPROB(APCDX,12,X,0)),U)
+47 IF 'Y
QUIT
+48 SET Y=$PIECE($$ICDDX^ICDCODE(Y),U,2)
+49 SET APCDOA=APCDOA_Y_":"
End DoDot:2
+50 ;update PROBLEM entry
+51 SET APCDN01=$PIECE(APCDICDS,";")
IF APCDN01'["."
SET APCDN01=APCDN01_"."
+52 ;Default to .9999 if no map
IF APCDN01=""
SET APCDN01=".9999"
+53 IF APCDN01'["."
SET APCDN01=APCDN01_"."
+54 SET APCDN01=+$$CODEN^ICDCODE(APCDN01,80)
+55 IF 'APCDN01
QUIT
+56 ;Can't change it if it isn't in file 80
IF APCDN01=-1
QUIT
+57 ;new additional codes
SET APCDNA=$PIECE(APCDICDS,";",2,999)
+58 ;now set AUPNPROB
+59 KILL DIE,DA,DR
SET DA=APCDX
SET DR=".01////"_APCDN01
SET DIE="^AUPNPROB("
DO ^DIE
KILL DIE,DA,DR
+60 ;ADDITIONAL MULTIPLE
+61 ;DELETE OUT OLD ADDITIONAL MULTIPLE
+62 SET APCDZ=0
FOR
SET APCDZ=$ORDER(^AUPNPROB(APCDX,12,APCDZ))
IF APCDZ'=+APCDZ
QUIT
Begin DoDot:2
+63 NEW DIE,DA,DR
+64 SET DIE="^AUPNPROB("_APCDX_",12,"
SET DA=APCDZ
SET DA(1)=APCDX
SET DR=".01///@"
DO ^DIE
End DoDot:2
+65 ;SET 12 NODES
+66 SET APCDFNUM=9000011.12
+67 SET APCDNODE=12
+68 FOR APCDZ=1:1
SET APCDY=$PIECE(APCDNA,";",APCDZ)
IF APCDY=""
QUIT
Begin DoDot:2
+69 NEW APCDP,APCDFDA,ERR
+70 IF APCDY'["."
SET APCDY=APCDY_"."
+71 SET APCDP=+$$CODEN^ICDCODE(APCDY,80)
+72 IF 'APCDP
QUIT
+73 IF APCDP=-1
QUIT
+74 SET APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
+75 DO UPDATE^DIE("","APCDFDA","","ERR")
End DoDot:2
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+76 ;
FH ;
+1 SET APCDX=0
+2 FOR
SET APCDX=$ORDER(^AUPNFH(APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+3 ;
+4 ;Update log entry
+5 SET $PIECE(^XTMP("BSTSPBFH"),U,3)="Converting family history entry: "_APCDX
+6 ;
+7 NEW APCDCI,APCDICDS,APCDO01,APCDOA,X,Y,APCDN01,APCDNA,APCDLOGE
+8 NEW APCDZ,APCDFNUM,APCDY
+9 IF '$DATA(^AUPNFH(APCDX,0))
QUIT
+10 ;only snomed coded fh ENTRIES
SET APCDCI=$PIECE($GET(^AUPNFH(APCDX,0)),U,13)
+11 IF APCDCI=""
QUIT
+12 ;Log entry
SET ^XTMP("BSTSPBFH","F",APCDX)=""
+13 ;ALL ICD CODES
SET APCDICDS=$PIECE($$CONC^BSTSAPI(APCDCI_"^^^1"),U,5)
+14 SET APCDO01=$PIECE(^AUPNFH(APCDX,0),U,1)
+15 SET APCDOA=""
+16 SET X=0
FOR
SET X=$ORDER(^AUPNFH(APCDX,11,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 SET Y=$PIECE($GET(^AUPNFH(APCDX,11,X,0)),U)
+18 IF 'Y
QUIT
+19 SET Y=$PIECE($$ICDDX^ICDCODE(Y),U,2)
+20 SET APCDOA=APCDOA_Y_":"
End DoDot:2
+21 ;update fh entry
+22 SET APCDN01=$PIECE(APCDICDS,";")
+23 ;Default to .9999 if no map
IF APCDN01=""
SET APCDN01=".9999"
+24 IF APCDN01'["."
SET APCDN01=APCDN01_"."
+25 SET APCDN01=+$$CODEN^ICDCODE(APCDN01,80)
+26 IF 'APCDN01
QUIT
+27 IF APCDN01=-1
QUIT
+28 SET APCDNA=$PIECE(APCDICDS,";",2,999)
+29 ;now set AUPNFH
+30 KILL DIE,DA,DR
SET DA=APCDX
SET DR=".01////"_APCDN01
SET DIE="^AUPNFH("
DO ^DIE
KILL DIE,DA,DR
+31 SET APCDZ=0
FOR
SET APCDZ=$ORDER(^AUPNFH(APCDX,11,APCDZ))
IF APCDZ'=+APCDZ
QUIT
Begin DoDot:2
+32 SET DIE="^AUPNFH("_APCDX_",11,"
SET DA=APCDZ
SET DA(1)=APCDX
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+33 ;SET 11 NODES
+34 SET APCDFNUM=9000014.11
+35 FOR APCDZ=1:1
SET APCDY=$PIECE(APCDNA,";",APCDZ)
IF APCDY=""
QUIT
Begin DoDot:2
+36 NEW APCDP,APCDFDA,ERR
+37 IF APCDY'["."
SET APCDY=APCDY_"."
+38 SET APCDP=+$$CODEN^ICDCODE(APCDY,80)
+39 IF 'APCDP
QUIT
+40 IF APCDP=-1
QUIT
+41 SET APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
+42 DO UPDATE^DIE("","APCDFDA","","ERR")
End DoDot:2
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+43 ;
+44 ;Update log entry
+45 SET $PIECE(^XTMP("BSTSPBFH"),U,3)="Patch 2 problem/family history conversion completed"
+46 ;
+47 ;Remove lock
XPBFH LOCK -^TMP("BSTSPBFH")
+1 ;
+2 QUIT
